diff --git a/internal/library/ABC b/internal/library/ABC
new file mode 100644
index 00000000..27ac760c
--- /dev/null
+++ b/internal/library/ABC
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "18-Mar-88 16:09:05" {ERIS}<LISPCORE>INTERNAL>LIBRARY>ABC.;4 2101   

      changes to%:  (VARS ABCCOMS)

      previous date%: "29-Jul-87 12:04:16" {ERIS}<LISPCORE>INTERNAL>LIBRARY>ABC.;3)


(* "
Copyright (c) 1986, 1987, 1988 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT ABCCOMS)

(RPAQQ ABCCOMS ((VARS (MSRECORDTRANFLG T)
                          (DWIMIFYCOMPFLG)
                          (MSMACROPROPS COMPILERMACROPROPS)
                          (CLEANUPOPTIONS '(RC F))
                          (CROSSCOMPILING T)
                          (ASKEDITHIST T)
                          (RECOMPILEDEFAULT 'CHANGES)
                          (CROSSCOMPILING 'ASK))
                    (FILES (SOURCE)
                           FILESETS)
                    (P (MOVD? 'APPLY* 'SPREADAPPLY*)
                       [RESETVARS ((CROSSCOMPILING T))
                              (FILESLOAD EXPORTS.ALL)
                              (AND (EQ (ASKUSER DWIMWAIT 'N "Check imports? " NIL T)
                                       'Y)
                                   (ERSETQ (CHECKIMPORTS EXPORTFILES T]
                       (PRIN1 
             "**** SET IL:DFNFLG TO IL:PROP IF YOU EDIT SYSTEM SOURCES THAT CAN'T BE RUN INTERPRETED" 
                              T))))

(RPAQQ MSRECORDTRANFLG T)

(RPAQQ DWIMIFYCOMPFLG NIL)

(RPAQ MSMACROPROPS COMPILERMACROPROPS)

(RPAQQ CLEANUPOPTIONS (RC F))

(RPAQQ CROSSCOMPILING T)

(RPAQQ ASKEDITHIST T)

(RPAQQ RECOMPILEDEFAULT CHANGES)

(RPAQQ CROSSCOMPILING ASK)
(FILESLOAD (SOURCE)
       FILESETS)
(MOVD? 'APPLY* 'SPREADAPPLY*)
[RESETVARS ((CROSSCOMPILING T))
       (FILESLOAD EXPORTS.ALL)
       (AND (EQ (ASKUSER DWIMWAIT 'N "Check imports? " NIL T)
                'Y)
            (ERSETQ (CHECKIMPORTS EXPORTFILES T]
(PRIN1 "**** SET IL:DFNFLG TO IL:PROP IF YOU EDIT SYSTEM SOURCES THAT CAN'T BE RUN INTERPRETED" T)
(PUTPROPS ABC COPYRIGHT ("Xerox Corporation" 1986 1987 1988))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/internal/library/ARCLEANUP b/internal/library/ARCLEANUP
new file mode 100644
index 00000000..3b1e793f
--- /dev/null
+++ b/internal/library/ARCLEANUP
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Apr-92 18:06:57" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>ARCLEANUP.;8| 14846  

      changes to%:  (FNS AR.CLEANUP.DO.SUMMARIES)

      previous date%: "30-Mar-92 10:45:38" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>ARCLEANUP.;6|
)


(* ; "
Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT ARCLEANUPCOMS)

(RPAQQ ARCLEANUPCOMS
       [(FILES AREDIT ARINDEX)
        (COMS                                                (* ; "The main CLEANUP code")
              (FNS AR.CLEANUP AR.GET.NUMS.FROM.TDS AR.PRINT.AND.IP.FILE AR.QUERY.PRINT.AND.IP.FILE)
                                                             (* ; "Special versions of CLEANUP")
              (FNS AR.CLEANUP.DO.SUMMARIES AR.CLEANUP.REDO.SUMMARIES AR.CLEANUP.NO.SUMMARIES))
        (COMS                                                (* ; 
                                                          "List of names to generate summaries for")
              (INITVARS (AR.CLEANUP.HACKER.NAMES '(Bane Gadener Masinter Mitani Osamu Porter Prolog 
                                                        Shimizu Sybalsky vanMelle Welch))
                     (AR.CLEANUP.SORT.ORDER '(System%: Subsystem%: Status%: Priority%: Impact%:))
                     (AR.SUMMARY.DIRECTORY "{AR:MV:Envos}<LispARs>Summaries>"))
              (P (CL:PROCLAIM '(CL:SPECIAL AR.CLEANUP.HACKER.NAMES AR.CLEANUP.SORT.ORDER 
                                      AR.SUMMARY.DIRECTORY])

(FILESLOAD AREDIT ARINDEX)



(* ; "The main CLEANUP code")

(DEFINEQ

(AR.CLEANUP
  [LAMBDA (UPDATE.FLG INDEX.LOCAL.DIR SUMMARY.FLG SUMMARY.LOCAL.DIR)
                                                             (* ; "Edited  7-Dec-89 18:25 by jds")
    (PROG ([LOCAL.AR.INDEX.NAME (AND INDEX.LOCAL.DIR (CONCAT INDEX.LOCAL.DIR 'AR.INDEX]
           INDEX.WINDOW)
          (COND
             (LOCAL.AR.INDEX.NAME (printout T "copying old AR index to " LOCAL.AR.INDEX.NAME "...")
                    (COPYFILES AR.INDEX.DEFAULT.FILE.NAME LOCAL.AR.INDEX.NAME '>A)
                    (printout T "done" T)))
          [COND
             (UPDATE.FLG (PROG ((SAVED.TDS.NAME (CONCAT AR.INFO.FILE.NAME '-PROCESSED))
                                NUMBERS INDEX.WINDOW)
                               (COND
                                  ((NOT (INFILEP AR.INFO.FILE.NAME))
                                   (printout T "No TDS file --- AR update aborted" T)
                                   (RETURN)))
                               [SETQ NUMBERS
                                (SORT (CL:REMOVE-DUPLICATES
                                       (while (INFILEP AR.INFO.FILE.NAME)
                                          join (until (NLSETQ (RENAMEFILE AR.INFO.FILE.NAME 
                                                                             SAVED.TDS.NAME))
                                                      do (printout T 
                                                             "Can't rename TDS file --- trying again"
                                                                    T)
                                                            (BLOCK 5000))
                                                (AR.GET.NUMS.FROM.TDS SAVED.TDS.NAME]
                               (COND
                                  ((NULL NUMBERS)
                                   (printout T "No numbers found in TDS file --- AR update aborted" T
                                          )
                                   (RETURN)))
                               (printout T "Will update AR numbers:" T NUMBERS T)

                          (* ;; "update AR index")

                               (SETQ INDEX.WINDOW (CREATEW (CREATEREGION 400 200 400 65)
                                                         "old index"))
                               (AR.QFORM.GROUP.CREATE (OR LOCAL.AR.INDEX.NAME 
                                                          AR.INDEX.DEFAULT.FILE.NAME)
                                      INDEX.WINDOW)
                               (printout T "updating AR index....")
                               (AR.INDEX.UPDATE INDEX.WINDOW NUMBERS)
                               (CLOSEW INDEX.WINDOW)
                               (printout T "done" T)
                               (COND
                                  (LOCAL.AR.INDEX.NAME (printout T "deleting old AR index from " 
                                                              LOCAL.AR.INDEX.NAME "...")
                                         (DELFILE LOCAL.AR.INDEX.NAME)
                                         (printout T "done" T "copying new index to file server..."
                                                (COPYFILE LOCAL.AR.INDEX.NAME 
                                                       AR.INDEX.DEFAULT.FILE.NAME)
                                                "done" T]
          (if SUMMARY.FLG
              then (SETQ INDEX.WINDOW (CREATEW (CREATEREGION 660 100 350 132)))
                    (AR.QFORM.GROUP.CREATE (OR LOCAL.AR.INDEX.NAME AR.INDEX.DEFAULT.FILE.NAME)
                           INDEX.WINDOW)                     (* ; "make main unsorted summary")
                                                             (* ; "print summaries for each person")
                    (AR.CLEANUP.DO.SUMMARIES INDEX.WINDOW SUMMARY.LOCAL.DIR)
                    (CLOSEW INDEX.WINDOW])

(AR.GET.NUMS.FROM.TDS
(LAMBDA (FILENAME) (* ; "Edited 20-Feb-87 11:36 by jds") (* ;; "Gather the list of ARs that have changed from the %"Tool Driver Script%" file, where AREDIT makes note of edits that people make.") (PROG ((FILE (OPENSTREAM FILENAME (QUOTE INPUT) (QUOTE OLD))) NUMBERS) (SETQ NUMBERS (while (FILEPOS "  --  (" FILE NIL NIL NIL T) bind NUM? when (NUMBERP (SETQ NUM? (PROGN (READ FILE) (READ FILE)))) collect NUM?)) (CLOSEF FILE) (RETURN NUMBERS)))
)

(AR.PRINT.AND.IP.FILE
(LAMBDA (QFORMWINDOW FILENAME SUMMARY.LOCAL.DIR FIELDS-TO-PRINT) (* ; "Edited  1-Mar-88 17:36 by bvm") (* ;; "Take a query form and make a summary from it onto FILENAME.  If SUMMARY.LOCAL.DIR is given, the file is created there and then moved to the Summaries directory, else FILENAME is written directly (default dir is still the Summaries directory).") (* ;; "FIELDS-TO-PRINT is a listing of field-name & print-length pairs for what's to appear in the summary.  Defaults to whatever AR.PRINT defaults it to.") (LET* ((REMOTETXTFILE (CL:APPLY (FUNCTION PACKFILENAME.STRING) (QUOTE BODY) FILENAME (QUOTE EXTENSION) "txt" (AND (NOT (UNPACKFILENAME.STRING FILENAME (QUOTE HOST))) (BQUOTE (DIRECTORY (\, AR.SUMMARY.DIRECTORY)))))) (LOCALTXTFILE (COND (SUMMARY.LOCAL.DIR (CONCAT SUMMARY.LOCAL.DIR FILENAME ".txt")) (T (* ; "No Local directory specified, so put 'em right onto the main AR directory.") REMOTETXTFILE))) LOCALIPFILE) (printout T "Generating summary file: " FILENAME "... ") (SETQ LOCALTXTFILE (AR.MAKE.SUMMARY.FILE QFORMWINDOW LOCALTXTFILE FIELDS-TO-PRINT)) (COND (SUMMARY.LOCAL.DIR (* ; "Copy the text form of the summary to the AR directory") (printout T "copying... " (COPYFILE LOCALTXTFILE REMOTETXTFILE) " "))) (printout T "Creating Interpress file... " (SETQ LOCALIPFILE (AR.MAKE.SUMMARY.FILE QFORMWINDOW (AR.OPEN.IP.STREAM (PACKFILENAME.STRING (QUOTE EXTENSION) "IP" (QUOTE VERSION) NIL (QUOTE BODY) LOCALTXTFILE)) FIELDS-TO-PRINT)) " ") (COND (SUMMARY.LOCAL.DIR (* ; "Finally, copy the IP file back to the main AR directory and delete the local copies.") (printout T "copying... " (COPYFILE LOCALIPFILE (PACKFILENAME.STRING (QUOTE EXTENSION) "IP" (QUOTE VERSION) NIL (QUOTE BODY) REMOTETXTFILE)) " ") (DELFILE LOCALTXTFILE) (DELFILE LOCALIPFILE))) (printout T "done" T)))
)

(AR.QUERY.PRINT.AND.IP.FILE
(LAMBDA (INDEX.WINDOW.OR.FILE QLIST SLIST FILENAME SUMMARY.LOCAL.DIR FIELDS-TO-PRINT) (* ; "Edited 29-Feb-88 19:35 by bvm") (* ;; "Query on QLIST, sorted by SLIST, and make a summary and ip file for it.  If INDEX.WINDOW.OR.FILE is not a window, we'll create and close a fake window, in which case INDEX.WINDOW.OR.FILE can be the name of the index file to use.") (LET* ((INDEX.WINDOW (WINDOWP INDEX.WINDOW.OR.FILE)) (OPENED INDEX.WINDOW)) (if (NOT OPENED) then (* ; "Make a fake query window") (SETQ INDEX.WINDOW (CREATEW (CREATEREGION 660 100 350 65))) (LET ((AR.ALWAYS.CACHE.INDEX NIL)) (AR.QFORM.GROUP.CREATE (OR INDEX.WINDOW.OR.FILE AR.INDEX.DEFAULT.FILE.NAME) INDEX.WINDOW T))) (AR.QUERY INDEX.WINDOW QLIST SLIST) (AR.PRINT.AND.IP.FILE INDEX.WINDOW FILENAME SUMMARY.LOCAL.DIR FIELDS-TO-PRINT) (if (NOT OPENED) then (CLOSEW INDEX.WINDOW))))
)
)



(* ; "Special versions of CLEANUP")

(DEFINEQ

(AR.CLEANUP.DO.SUMMARIES
  [LAMBDA (INDEX.WINDOW SUMMARY.LOCAL.DIR)               (* ; "Edited  1-Apr-92 16:55 by jds")

    (* ;; "Make various specialized summaries, then personal ones for each hacker")

    [LET ((SORT.ORDER (REMOVE 'Status%: AR.CLEANUP.SORT.ORDER)))
                                                             (* ; "make report for Rooms")
         (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: >= Open/Unreleased)
                                                            (System%: IS Rooms))
                SORT.ORDER "RoomsSummary" SUMMARY.LOCAL.DIR) (* ; "make report for Loops")
         (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: >= Open/Unreleased)
                                                            (System%: IS LOOPS))
                SORT.ORDER "LoopsSummary" SUMMARY.LOCAL.DIR) (* ; "make report for Maiko")
         (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: >= Open/Unreleased)
                                                            (System%: IS Maiko))
                SORT.ORDER "MaikoSummary" SUMMARY.LOCAL.DIR) (* ; 
                                                           "make report for all Absolutely ARs")
         (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: >= Open/Unreleased)
                                                            (Priority%: IS Absolutely))
                AR.CLEANUP.SORT.ORDER "AbsolutelySummary" SUMMARY.LOCAL.DIR)

         (* ;; "Report on all documentation ARs:")

         (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: >= Open/Unreleased)
                                                            (OR (System%: IS Documentation)
                                                                (Subsystem%: IS Documentation)
                                                                (|Problem Type:| IS Documentation)))
                AR.CLEANUP.SORT.ORDER "DocSummary" SUMMARY.LOCAL.DIR)

         (* ;; "Make a report of all open ARs:")

         (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(Status%: >= Open/Unreleased)
                SORT.ORDER "OpenSummary" SUMMARY.LOCAL.DIR)

         (* ;; "make report for all Fixed ARs:")

         [AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(Status%: IS Fixed)
                SORT.ORDER "FixedSummary" SUMMARY.LOCAL.DIR '((Edit-Date%: 9 T)
                                                              (Date%: 9 T)
                                                              (System%: 13 T)
                                                              (Subsystem%: 14)
                                                              (Status%: 10 T)
                                                              (Attn%: 13)
                                                              (Subject%: 55)
                                                              (Priority%: 10)
                                                              (Impact%: 8)
                                                              (|Problem Type:| 13]
                                                             (* ; 
                                                     "print summary of Fixed and Closed for Medley")
         (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW '(AND (Status%: IS Closed)
                                                            (OR (Date%: >= 1-Jun-90)
                                                                (Edit-Date%: >= 1-Jun-90)))
                '(Status%: System%: Subsystem%:)
                "ClosedSummary" SUMMARY.LOCAL.DIR '((Edit-Date%: 9 T)
                                                    (Date%: 9 T)
                                                    (System%: 13 T)
                                                    (Subsystem%: 14)
                                                    (Status%: 10 T)
                                                    (Attn%: 13)
                                                    (Subject%: 55)
                                                    (Priority%: 10)
                                                    (Impact%: 8)
                                                    (|Problem Type:| 13]
    (for HACKER.NAME in AR.CLEANUP.HACKER.NAMES
       do (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW
                     `(Attn%: HAS ,(OR (SUBSTRING HACKER.NAME 1 4)
                                       HACKER.NAME))
                     AR.CLEANUP.SORT.ORDER
                     (CONCAT HACKER.NAME "Summary")
                     SUMMARY.LOCAL.DIR])

(AR.CLEANUP.REDO.SUMMARIES
(LAMBDA (INDEX.WINDOW SUMMARY.LOCAL.DIR) (* ; "Edited 24-Feb-88 19:27 by bvm") (AR.CLEANUP.DO.SUMMARIES INDEX.WINDOW) (* ; "Dunno why there's this extra random summary...") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW (QUOTE (OR (AND (System%: IS Programming% Environment) (Subsystem%: IS Break% Package)) (AND (System%: IS Common% Lisp) (OR (Subsystem%: IS Debugging) (Subsystem%: IS Break% Package) (Subsystem%: IS Error% System))))) (QUOTE (Subsystem%: Status%:)) "KelleySummary" SUMMARY.LOCAL.DIR))
)

(AR.CLEANUP.NO.SUMMARIES
(LAMBDA (UPDATE.FLG INDEX.LOCAL.DIR SUMMARY.FLG SUMMARY.LOCAL.DIR) (* ; "Edited 24-Feb-88 17:06 by bvm") (AR.CLEANUP UPDATE.FLG INDEX.LOCAL.DIR NIL SUMMARY.LOCAL.DIR))
)
)



(* ; "List of names to generate summaries for")


(RPAQ? AR.CLEANUP.HACKER.NAMES '(Bane Gadener Masinter Mitani Osamu Porter Prolog Shimizu 
                                          Sybalsky vanMelle Welch))

(RPAQ? AR.CLEANUP.SORT.ORDER '(System%: Subsystem%: Status%: Priority%: Impact%:))

(RPAQ? AR.SUMMARY.DIRECTORY "{AR:MV:Envos}<LispARs>Summaries>")

(CL:PROCLAIM '(CL:SPECIAL AR.CLEANUP.HACKER.NAMES AR.CLEANUP.SORT.ORDER AR.SUMMARY.DIRECTORY))
(PUTPROPS ARCLEANUP COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1992))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1698 8805 (AR.CLEANUP 1708 . 5632) (AR.GET.NUMS.FROM.TDS 5634 . 6105) (
AR.PRINT.AND.IP.FILE 6107 . 7924) (AR.QUERY.PRINT.AND.IP.FILE 7926 . 8803)) (8850 14249 (
AR.CLEANUP.DO.SUMMARIES 8860 . 13514) (AR.CLEANUP.REDO.SUMMARIES 13516 . 14047) (
AR.CLEANUP.NO.SUMMARIES 14049 . 14247)))))
STOP
\ No newline at end of file
diff --git a/internal/library/ARCLEANUP.TEDIT b/internal/library/ARCLEANUP.TEDIT
new file mode 100644
index 00000000..bb4e8348
--- /dev/null
+++ b/internal/library/ARCLEANUP.TEDIT
@@ -0,0 +1 @@
+
ARCLEANUP Package --- Michael Sannella 
(and augmented by Susana Wessling, 26-mar-87)


The file {eris}<lispcore>internal>library>ARCLEANUP.LCOM contains a few functions used to update the AR database and to print summaries.

(AR.CLEANUP UPDATE.FLG INDEX.LOCAL.DIR SUMMARY.FLG SUMMARY.LOCAL.DIR ]

This is the main function, which should be run every few days, preferably just as you go out the door (so your machine can crunch on it overnight).  If UPDATE.FLG is non-NIL, all of the ARs that have been touched since the last update are scanned, and the AR database is updated.  If SUMMARY.FLG is non-NIL, a set of summaries is generated on {eris}<lispars>summaries> and press-fied.

INDEX.LOCAL.DIR and SUMMARY.LOCAL.DIR are used if you want the AR index and/or the summary reports to be cached on a local disk.  This speeds up the prosess considerably, along with reducing ethernet load.  If non-NIL, each of these should be a host/directory pair, which will be PACKed on the front of a filename to generate the caching filename.  These are not just flags, with caching defaulting to {DSK}, so that I can use multiple partitions for caching.  The issue is space:  Sometimes the local disk does not have enough room for two copies of the AR index, or for both the txt and press version of the grang summary.

Example: 

AR.CLEANUP (T NIL T NIL)

-- does cleanup with no caching

AR.CLEANUP (T {DSK} T {DSK2})

--- caches index on {DSK}, and the summaries on {DSK2}

AR.CLEANUP (T {DSK})

--- just does index update, caching on {DSK}.



Another useful function:

AR.CLEANUP.REDO.SUMMARIES:  just generates summaries, does not do a new cleanup.
\ No newline at end of file
diff --git a/internal/library/AREDIT b/internal/library/AREDIT
new file mode 100644
index 00000000..02051eec
--- /dev/null
+++ b/internal/library/AREDIT
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "17-Sep-90 15:37:53" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>AREDIT.;4| 94426  

      changes to%:  (VARS AREDITCOMS)

      previous date%: " 2-Jul-90 15:15:42" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>AREDIT.;3|)


(* ; "
Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT AREDITCOMS)

(RPAQQ AREDITCOMS
       [(COMS                                                (* ; "AR.FORM functions and variables")
              (FNS AR.FORM AR.FORM.GROUP.CREATE AR.FORM.CREATE AR.FORM.ICONFN AR.BUTTON.OBJ.CREATE 
                   AR.PROTECT.WARNING AR.INSTALL.TEDITSTREAM AR.KILL.ATTACHED.TEDIT.CLOSEFN))
        (COMS                                                (* ; "Managing buttons")
              (FNS AR.BUTTON.GET.MENU AR.BUTTON.GET.SUBMENU AR.BUTTONFN.DOMENU AR.BUTTONFN.DOSUBMENU
                   AR.RESET.SEL AR.REPLACE.FIELD.VAL AR.GET.ASSOCIATED.MENU.VAL AR.BUTTONFN.SELFIELD
                   AR.BUTTONFN.OFFER.DEFAULT AR.MAP.BUTTONS AR.FIND.BUTTON 
                   AR.GET.BUTTON.FIELD.AS.TEXT AR.GET.BUTTON.FIELD.SHAPE AR.GET.NUMBER.FIELD))
        (COMS                                                (* ; "Handling the command menu")
              (FNS AR.FORM.MENU.BUTTONFN AR.FORM.MENU.ACTIONFN AR.FORM.PROGRAMMATIC.GET 
                   AR.FORM.PROGRAMMATIC.PUT AR.DISCONNECT.WINDOW AR.RECONNECT.WINDOW AR.MARK.ACTIVE 
                   AR.TOBJ.ACTIVEP AR.FORM.MENU.TITLEMENUFN AR.MENU.CR.FN 
                   AR.GET.MENU.FROM.MAIN.WINDOW AR.CONFIRM))
        (COMS                                                (* ; "CLEAR")
              (FNS AR.MENU.FN.CLEAR AR.FORM.CLEAR AR.FORM.SET.TO.EMPTY AR.DELETE.FIELD.VAL))
        (COMS                                                (* ; "GET")
              (FNS AR.MENU.FN.GET AR.GET.AR AR.FETCH.AND.PARSE.AR AR.SET.FORM.NUMBER 
                   AR.GET.SCRATCH.STREAM AR.COPY.AND.INDEX.AR AR.MALFORMED.AR AR.TEXTSTREAM.LOAD 
                   AR.REPLACE.FILL.INS))
        (COMS                                                (* ; "PUT")
              (FNS AR.MENU.FN.PUT AR.MENU.FN.PUT&GET AR.MENU.FN.PUT&GETNEXT AR.FORM.SAVE 
                   AR.GET.SUBMIT.NUM AR.FIND.EDIT.CHANGES AR.NOTE.FIELD.CHANGED AR.SEND.MESSAGE 
                   AR.COPY.BUTTON.FIELD AR.UPDATE.AR.INFO AR.PUT.FAILED)
              (FNS AR.CHECK.FIELDS AR.CHECK.MENU AR.CHECK.SHORTSTRING AR.CHECK.SUBMENU))
        (COMS                                                (* ; "Special")
              (FNS AR.FORM.GET/PUT.FILE AR.GET.NEXT AR.FORM.FILL.IN.DEFAULTS AR.CURRENT.LISP.VERSION)
                                                             (* ; "Misc")
              (FNS AR.PROMPT AR.PROMPT.PRINT AR.PROMPT.CLEAR AR.GET.FILENAME AR.READ.NUMBER 
                   AR.FILENAME AR.READ.BYTES AR.USERNAME))
        (COMS                                                (* ; 
                                "These have special knowledge of TEdit I wish I didn't really need")
              (FNS TEDIT.FAST.RAW.INCLUDE AR.PIECE.CHANGED)
                                                             (* ; "Patch for Lyric")
              (FNS AR.UNSELECT.ITEM))
        (COMS                                                (* ; "Hardcopying AR's")
              (FNS AR.DISPLAY AR.HARDCOPY AR.DISPLAY.TEXTSTREAM)
              (INITVARS (AR.HARDCOPY.WIDTH 504)
                     (AR.HARDCOPY.MAXLENGTH 40000)
                     (AR.DISPLAY.FORMAT NIL)))
        (COMS                                                (* ; 
                          "These VARS are AR-system change these to work on different AR databases")
              (VARS AR.FORM.FORMAT AR.FORM.SPECS AR.INTERESTING.SUBMIT.FIELDS)
              (VARS (AR.DIRECTORY "{AR:MV:Envos}<LispARs>")
                    (AR.INFO.FILE.NAME "{AR:MV:Envos}<LispARs>LispARs.tds")
                    (AR.SUBMIT.NUM.FILE.NAME "{AR:MV:Envos}<LispARs>LispARs.num")
                    (AR.IDENTIFICATION.STRING "AR")))
        (INITVARS (ARBUTTONFONT (FONTCREATE 'HELVETICA 12 'BOLD))
               (ARFONT (FONTCREATE 'TIMESROMAN 10))
               (ARBOLDFONT (FONTCREATE 'HELVETICA 10 'BOLD))
               (ARHEADERFONT (FONTCREATE 'HELVETICA 8))
               (AR.ICONFONT (FONTCREATE 'GACHA 8))
               (AR.FILE.TRIES 10)
               (AR.NO.MESSAGE.FLG NIL))
        (VARS (AR.NULL.BUTTON.VALUE (PACKC))
              AR.FORM.MENU.TITLEMENU.ITEMS
              (AR.FORM.MENU.TITLEMENU)
              AR.FORM.ICONSPEC)
        [DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS AR.FORM.ICONSPEC AR.NULL.BUTTON.VALUE 
                                                AR.HARDCOPY.PAGENO.KLUDGE.OFFSET AR.MENU.READTABLE 
                                                TEDIT.READTABLE AR.FORM.MENU.TITLEMENU)
               (LOCALVARS . T)
               (P                                            (* ; 
                                                       "Need TEDITDECLS for TEDIT.FAST.RAW.INCLUDE")
                  (OR (GET 'TEDITDECLS 'FILE)
                      (LOAD 'TEDITDECLS]
        [DECLARE%: EVAL@COMPILE DOCOPY
               (P (CL:PROCLAIM '(CL:SPECIAL AR.INFO.FILE.NAME AR.SUBMIT.NUM.FILE.NAME AR.DIRECTORY 
                                       AR.NO.MESSAGE.FLG ARBUTTONFONT ARFONT ARBOLDFONT ARHEADERFONT
                                       AR.ICONFONT AR.FILE.TRIES AR.HARDCOPY.MAXLENGTH AR.FORM.FORMAT
                                       AR.FORM.SPECS AR.HARDCOPY.WIDTH AR.DISPLAY.FORMAT 
                                       AR.IDENTIFICATION.STRING AR.FORM.MENU.TITLEMENU.ITEMS 
                                       AR.INTERESTING.SUBMIT.FIELDS]
        (FILES (SYSLOAD)
               ARQUERY TABLEBROWSER TEDIT READNUMBER)
        [VARS (AR.HARDCOPY.PAGENO.KLUDGE.OFFSET (COND ((> (IDATE TEDITSYSTEMDATE)
                                                          (IDATE "23-feb-88 0000"))
                                                             (* ; "Bug was fixed")
                                                       0)
                                                      (T 2]
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (COND ((EQ MAKESYSNAME :LYRIC)
                                                  (FILESLOAD (SYSLOAD)
                                                         MVALUESPATCH)
                                                  (MOVD? 'AR.UNSELECT.ITEM 'TB.UNSELECT.ITEM NIL T)))
                                           (PUTD 'AR.UNSELECT.ITEM NIL))
               (P                                            (* ; 
                                     "Install background menu command.  Smash any previous AREdit.")
                  [/RPLACD [OR (CL:ASSOC "AR Edit" BackgroundMenuCommands :TEST 'STRING-EQUAL)
                               (CAR (RPAQ BackgroundMenuCommands (CONS (LIST "AR Edit")
                                                                           BackgroundMenuCommands))]
                         '('(AR.FORM)
                           "Create a new AR editor for the Lisp AR database"
                           (SUBITEMS ("New AR form" '(AR.FORM)
                                            
                                         "Creates a new AR editor, cleared ready to submit a new AR."
                                            )
                                  ("Load AR" '(AR.FORM (AR.READ.NUMBER))
                                         "Creates a new AR editor and loads a specified AR into it")
                                  ("Display AR" '(AR.DISPLAY (AR.READ.NUMBER))
                                         "Displays a specified AR in a read-only window")
                                  ("AR Query Form" '(AR.QFORM.CREATE)
                                         "Creates an AR Query Form"]
                  (RPAQ BackgroundMenu )))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA AR.PROMPT.PRINT])



(* ; "AR.FORM functions and variables")

(DEFINEQ

(AR.FORM
(LAMBDA (NUM) (* ; "Edited 22-Feb-88 17:13 by bvm") (ADD.PROCESS (BQUOTE ((\, (FUNCTION AR.FORM.GROUP.CREATE)) (QUOTE (\, NUM)) (QUOTE (\, (PROGN (* ; "Get region here in the mouse process so that user can ^E") (GETREGION 450 200)))))) (QUOTE NAME) (QUOTE AR.FORM.NEW)))
)

(AR.FORM.GROUP.CREATE
(LAMBDA (INITIAL.NUM FORMWINDOW) (* ; "Edited  4-Aug-88 15:24 by bvm") (PROG (FORMSTREAM MENUW WREG) (if (WINDOWP FORMWINDOW) then (* ; "Already have window") (SETQ WREG (WINDOWPROP FORMWINDOW (QUOTE REGION))) else (SETQ WREG (OR (REGIONP FORMWINDOW) (GETREGION 450 200))) (replace (REGION HEIGHT) of WREG with (- (fetch (REGION HEIGHT) of WREG) (HEIGHTIFWINDOW (TIMES 2 (FONTPROP DEFAULTFONT (QUOTE HEIGHT)))) 40)) (* ; "Subtract out the height for the menu and prompt windows.") (SETQ FORMWINDOW (CREATEW WREG "New Bug Report"))) (* ;; "set up main window") (WINDOWADDPROP FORMWINDOW (QUOTE CLOSEFN) (FUNCTION AR.KILL.ATTACHED.TEDIT.CLOSEFN)) (WINDOWPROP FORMWINDOW (QUOTE MINSIZE) (CONS 450 60)) (WINDOWPROP FORMWINDOW (QUOTE AR.WINDOW.PROC.NAME) (QUOTE AR.FORM)) (WINDOWPROP FORMWINDOW (QUOTE ICONFN) (FUNCTION AR.FORM.ICONFN)) (* ;; "set up menu window") (SETQ MENUW (CREATEW (create REGION LEFT _ (fetch (REGION LEFT) of WREG) BOTTOM _ (fetch (REGION PTOP) of WREG) WIDTH _ (fetch (REGION WIDTH) of WREG) HEIGHT _ 40) (CONCAT AR.IDENTIFICATION.STRING " Bug Report Editor"))) (ATTACHWINDOW MENUW FORMWINDOW (QUOTE TOP) (QUOTE JUSTIFY) NIL) (WINDOWPROP MENUW (QUOTE MAXSIZE) (CONS 0 40)) (WINDOWPROP MENUW (QUOTE MINSIZE) (CONS 0 40)) (WINDOWPROP MENUW (QUOTE AR.WINDOW.PROC.NAME) (QUOTE AR.FORM.MENU)) (if (NOT (AND (BOUNDP (QUOTE AR.MENU.READTABLE)) (READTABLEP AR.MENU.READTABLE))) then (SETQ AR.MENU.READTABLE (COPYREADTABLE TEDIT.READTABLE)) (TEDIT.SETFUNCTION (CHARCODE CR) (FUNCTION AR.MENU.CR.FN) AR.MENU.READTABLE)) (GETPROMPTWINDOW FORMWINDOW 2) (PROGN (* ; "First, install the menu.  It would be nice to do this last (since you can't use it yet), but need it for setting the form number") (AR.FORM.CREATE MENUW ARBUTTONFONT (QUOTE ((New FIELDTYPE BUTTON FN AR.FORM.MENU.BUTTONFN) (Get FIELDTYPE BUTTON FN AR.FORM.MENU.BUTTONFN) (Put FIELDTYPE BUTTON FN AR.FORM.MENU.BUTTONFN) (Number%: FIELDTYPE STRING))) (QUOTE (New TAB Get TAB Put TAB Number%: TAB CR)) (LIST (QUOTE READTABLE) AR.MENU.READTABLE (QUOTE TITLEMENUFN) (FUNCTION NILL) (QUOTE PROMPTWINDOW) (QUOTE DON'T))) (AND NIL (until (WINDOWPROP MENUW (QUOTE LINES)) do (* ; "wait until the menu is totally initialized.  Is this kludge necessary?") (BLOCK 1000)))) (SETQ FORMSTREAM (AR.FORM.CREATE FORMWINDOW ARBOLDFONT AR.FORM.SPECS AR.FORM.FORMAT (QUOTE DON'T))) (* ; "create AR form for main window") (if (OR (NULL INITIAL.NUM) (EQ (AR.GET.AR FORMWINDOW INITIAL.NUM FORMSTREAM) (QUOTE XCL:FILE-NOT-FOUND))) then (* ; "Either nothing to get, or AR doesn't exist, so pretend it was just a New command") (AR.FORM.CLEAR FORMSTREAM T T)) (* ; "Now that we have the textstream we want, let TEdit display it") (AR.INSTALL.TEDITSTREAM FORMWINDOW FORMSTREAM) (* ;; "Now that we're about ready, enable the title menu.  You might think this was a textprop, but you'd be wrong.") (WINDOWPROP MENUW (QUOTE TEDIT.TITLEMENUFN) (FUNCTION AR.FORM.MENU.TITLEMENUFN)) (replace (TEXTOBJ MENUFLG) of (TEXTOBJ MENUW) with T) (RETURN FORMWINDOW)))
)

(AR.FORM.CREATE
(LAMBDA (FORMWINDOW BUTTONFONT FORM.SPECS FORM.FORMAT TEDITPROPS) (* ; "Edited 17-Feb-88 15:47 by bvm") (* ;; "Create an AR form in FORMWINDOW as specified by FORM.SPECS (button details) and FORM.FORMAT (layout of the fields).  BUTTONFONT is used for buttons that don't specify their own font in FORM.SPECS.  TEDITPROPS is passed on to TEdit; if it is the symbol DON'T, we don't create a TEdit process, but just return the textstream.") (LET ((FORMSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (BQUOTE (FONT (\, ARFONT) PARALOOKS (PARALEADING 2) TEDIT.TENTATIVE NIL)))) (NTABS 0) (WIDTH (WINDOWPROP FORMWINDOW (QUOTE WIDTH))) (CH# 1) BUTTON.POSITIONS SELECT.POINTS TAB.CH# TABSTOPS) (for FIELD.OR.SPACE in FORM.FORMAT do (BLOCK) (if (EQ FIELD.OR.SPACE (QUOTE TAB)) then (* ; "Separates fields all on one line") (TEDIT.INSERT FORMSTREAM "	" (SETQ TAB.CH# CH#)) (add NTABS 1) (add CH# 1) elseif (EQ FIELD.OR.SPACE (QUOTE CR)) then (* ; "Go to a new line.  Come up with tabs to divide the space evenly among the fields") (if (> NTABS 0) then (push TABSTOPS NTABS TAB.CH#) (SETQ NTABS 0)) (TEDIT.INSERT FORMSTREAM "
" CH#) (add CH# 1) elseif (STRINGP FIELD.OR.SPACE) then (TEDIT.INSERT FORMSTREAM FIELD.OR.SPACE CH#) (add CH# (NCHARS FIELD.OR.SPACE)) else (* ; "Make a button") (LET* ((BUTTONSPEC (CDR (ASSOC FIELD.OR.SPACE FORM.SPECS))) (BUTTON.TYPE (LISTGET BUTTONSPEC (QUOTE FIELDTYPE))) (BUTTON.OBJ (AR.BUTTON.OBJ.CREATE BUTTONSPEC FIELD.OR.SPACE BUTTONFONT)) (PRE.FIELD (SELECTQ BUTTON.TYPE (BUTTON "") ((MENU SUBMENU) "  {") "  ")) (PRE.FIELD.NCHARS (NCHARS PRE.FIELD))) (BLOCK) (TEDIT.INSERT.OBJECT BUTTON.OBJ FORMSTREAM CH#) (* ; "Insert the button object, make it unprotected") (push BUTTON.POSITIONS CH#) (add CH# 1) (if (> PRE.FIELD.NCHARS 0) then (TEDIT.INSERT FORMSTREAM PRE.FIELD CH#) (if (NOT (IMAGEOBJPROP BUTTON.OBJ (QUOTE AR.PROTECTED.FLG))) then (* ; "Allow selection after the pre-field") (push SELECT.POINTS (+ CH# (SUB1 PRE.FIELD.NCHARS)))) (add CH# PRE.FIELD.NCHARS)) (IMAGEOBJPROP BUTTON.OBJ (QUOTE AR.FIELD.START) (ADD1 PRE.FIELD.NCHARS)) (IMAGEOBJPROP BUTTON.OBJ (QUOTE AR.FIELD.LEN) 0) (* ; "Field currently empty") (SELECTQ BUTTON.TYPE ((MENU SUBMENU) (* ; "Close the braces") (TEDIT.INSERT FORMSTREAM "}" CH#) (add CH# 1)) NIL)))) (TEDIT.LOOKS FORMSTREAM (QUOTE (PROTECTED ON)) 1 CH#) (* ; "default char looks: everything is protected") (for N in BUTTON.POSITIONS do (* ; "Let buttons be touched") (TEDIT.LOOKS FORMSTREAM (QUOTE (PROTECTED OFF)) N 1)) (for N in SELECT.POINTS do (* ; "Allow selection after string buttons") (TEDIT.LOOKS FORMSTREAM (QUOTE (SELECTPOINT ON)) N 1)) (while TABSTOPS bind CACHED.TABS TB do (* ; "Process each <#tabs chpos> pair and set a tab stop there.") (SETQ NTABS (pop TABSTOPS)) (TEDIT.PARALOOKS FORMSTREAM (if (CDR (ASSOC NTABS CACHED.TABS)) else (* ; "Cache tab settings for this number of tabs") (push CACHED.TABS (CONS NTABS (SETQ TB (BQUOTE (TABS (NIL (\,@ (for I from 1 to NTABS bind (TABWIDTH _ (IQUOTIENT WIDTH (ADD1 NTABS))) collect (CONS (ITIMES I TABWIDTH) (QUOTE LEFT)))))))))) TB) (pop TABSTOPS) 1)) (TEDIT.STREAMCHANGEDP FORMSTREAM T) (if (EQ TEDITPROPS (QUOTE DON'T)) then (* ; "Don't install it") FORMSTREAM else (AR.INSTALL.TEDITSTREAM FORMWINDOW FORMSTREAM TEDITPROPS))))
)

(AR.FORM.ICONFN
(LAMBDA (WINDOW OLDICON) (* ; "Edited  1-Mar-88 17:33 by bvm") (OR OLDICON (TITLEDICONW AR.FORM.ICONSPEC (WINDOWPROP WINDOW (QUOTE AR.FORM.NUMBER)) AR.ICONFONT (WINDOWPROP WINDOW (QUOTE ICONPOSITION)) NIL NIL (QUOTE FILE))))
)

(AR.BUTTON.OBJ.CREATE
(LAMBDA (BUTTONSPEC BUTTON.NAME BUTTON.FONT) (* ; "Edited  4-Aug-88 15:27 by bvm") (PROG ((BUTTON.TYPE (LISTGET BUTTONSPEC (QUOTE FIELDTYPE))) OBJ FONT TEM) (if (AND (EQ BUTTON.TYPE (QUOTE STRING)) (LISTGET BUTTONSPEC (QUOTE MAXCHARS))) then (* ; "if a string has a max length given, treat it as a SHORTSTRING") (SETQ BUTTON.TYPE (QUOTE SHORTSTRING))) (SETQ OBJ (MBUTTON.CREATE BUTTON.NAME (OR (LISTGET BUTTONSPEC (QUOTE FN)) (SELECTQ BUTTON.TYPE (PROTECTEDSTRING (FUNCTION AR.PROTECT.WARNING)) ((STRING SHORTSTRING) (FUNCTION AR.BUTTONFN.SELFIELD)) (MENU (FUNCTION AR.BUTTONFN.DOMENU)) (SUBMENU (FUNCTION AR.BUTTONFN.DOSUBMENU)) (ERROR "Bad Button Type" BUTTON.TYPE))) (if (SETQ FONT (LISTGET BUTTONSPEC (QUOTE FONT))) then (FONTCREATE (if (LITATOM FONT) then (* ; "a method of indirection") (EVALV FONT) else FONT)) else BUTTON.FONT))) (IMAGEOBJPROP OBJ (QUOTE AR.CHECK.FN) (SELECTQ BUTTON.TYPE ((BUTTON PROTECTEDSTRING STRING) (FUNCTION NILL)) (SHORTSTRING (FUNCTION AR.CHECK.SHORTSTRING)) (MENU (FUNCTION AR.CHECK.MENU)) (SUBMENU (FUNCTION AR.CHECK.SUBMENU)) (ERROR "Bad Button Type" BUTTON.TYPE))) (SELECTQ BUTTON.TYPE ((BUTTON PROTECTEDSTRING MENU SUBMENU) (IMAGEOBJPROP OBJ (QUOTE AR.PROTECTED.FLG) BUTTON.TYPE)) NIL) (SELECTQ BUTTON.TYPE (SHORTSTRING (IMAGEOBJPROP OBJ (QUOTE AR.MAX.LEN) (LISTGET BUTTONSPEC (QUOTE MAXCHARS)))) (MENU (IMAGEOBJPROP OBJ (QUOTE AR.ASSOCIATED.SUBMENU) (LISTGET BUTTONSPEC (QUOTE ASSOCSUBMENU))) (IMAGEOBJPROP OBJ (QUOTE AR.MENU.LIST) (LISTGET BUTTONSPEC (QUOTE MENULIST)))) (SUBMENU (IMAGEOBJPROP OBJ (QUOTE AR.ASSOCIATED.MENU) (LISTGET BUTTONSPEC (QUOTE ASSOCMENU))) (IMAGEOBJPROP OBJ (QUOTE AR.SUBMENU.LIST) (LISTGET BUTTONSPEC (QUOTE SUBMENULIST)))) NIL) (if (SETQ TEM (LISTGET BUTTONSPEC (QUOTE INITIALVALUE))) then (IMAGEOBJPROP OBJ (QUOTE INITIALVALUE) TEM)) (if (SETQ TEM (LISTGET BUTTONSPEC (QUOTE FILLINVALUE))) then (IMAGEOBJPROP OBJ (QUOTE FILLINVALUE) TEM)) (RETURN OBJ)))
)

(AR.PROTECT.WARNING
(LAMBDA (OBJ SEL WINDOW) (* ; "Edited 20-Jul-88 17:04 by bvm") (AR.PROMPT.PRINT WINDOW :CLEAR "The field %"" (IMAGEOBJPROP OBJ (QUOTE MBTEXT)) "%" is not editable."))
)

(AR.INSTALL.TEDITSTREAM
(LAMBDA (FORMWINDOW FORMSTREAM TEDITPROPS) (* ; "Edited 12-Feb-88 15:59 by bvm") (* ;; "Given a TEdit stream FORMSTREAM, install it in the window FORMWINDOW") (LET ((FORMWINDOW.PROC (WINDOWPROP FORMWINDOW (QUOTE PROCESS))) NEWPROC TEM) (COND ((AND FORMWINDOW.PROC (PROCESSP FORMWINDOW.PROC)) (TEDIT.KILL FORMWINDOW))) (SETQ NEWPROC (TEDIT FORMSTREAM FORMWINDOW NIL (APPEND TEDITPROPS (BQUOTE (FONT (\, ARFONT) SEL DON'T LEAVETTY T TEDIT.TENTATIVE NIL))))) (if (SETQ TEM (WINDOWPROP FORMWINDOW (QUOTE AR.WINDOW.PROC.NAME))) then (PROCESSPROP NEWPROC (QUOTE NAME) TEM))))
)

(AR.KILL.ATTACHED.TEDIT.CLOSEFN
(LAMBDA (WINDOW) (* edited%: "30-Aug-84 09:58") (for AW in (ATTACHEDWINDOWS WINDOW) bind TSTREAM when (SETQ TSTREAM (WINDOWPROP AW (QUOTE TEXTSTREAM))) do (DETACHWINDOW AW) (TEDIT.KILL (TEXTOBJ TSTREAM)) (CLOSEW AW) finally (if (SETQ TSTREAM (WINDOWPROP WINDOW (QUOTE TEXTSTREAM))) then (TEDIT.KILL (TEXTOBJ TSTREAM)))))
)
)



(* ; "Managing buttons")

(DEFINEQ

(AR.BUTTON.GET.MENU
(LAMBDA (OBJ) (* ; "Edited 12-Feb-88 11:49 by bvm") (OR (IMAGEOBJPROP OBJ (QUOTE AR.MENU)) (LET ((MENU (create MENU ITEMS _ (BQUOTE ((\,@ (IMAGEOBJPROP OBJ (QUOTE AR.MENU.LIST))) (NIL (QUOTE (\, AR.NULL.BUTTON.VALUE))))) TITLE _ (IMAGEOBJPROP OBJ (QUOTE MBTEXT))))) (IMAGEOBJPROP OBJ (QUOTE AR.MENU) MENU) MENU)))
)

(AR.BUTTON.GET.SUBMENU
(LAMBDA (OBJ ASSOCIATED.MENU.VAL) (* ; "Edited 12-Feb-88 11:53 by bvm") (* ;; "Get the submenu from OBJ associated with ASSOCIATED.MENU.VAL.  The submenus are stored as a plist on the AR.SUBMENUS prop") (LET ((SUBMENUS (IMAGEOBJPROP OBJ (QUOTE AR.SUBMENUS))) MENU) (if (LISTGET SUBMENUS ASSOCIATED.MENU.VAL) else (SETQ MENU (create MENU ITEMS _ (BQUOTE ((\,@ (LISTGET (IMAGEOBJPROP OBJ (QUOTE AR.SUBMENU.LIST)) ASSOCIATED.MENU.VAL)) (NIL (QUOTE (\, AR.NULL.BUTTON.VALUE))))) TITLE _ (IMAGEOBJPROP OBJ (QUOTE MBTEXT)))) (if SUBMENUS then (LISTPUT SUBMENUS ASSOCIATED.MENU.VAL MENU) else (IMAGEOBJPROP OBJ (QUOTE AR.SUBMENUS) (LIST ASSOCIATED.MENU.VAL MENU))) MENU)))
)

(AR.BUTTONFN.DOMENU
(LAMBDA (OBJ SEL WINDOW) (* ; "Edited 12-Feb-88 16:05 by bvm") (LET ((NEWVAL (MENU (AR.BUTTON.GET.MENU OBJ))) ASSOC.SUBMENU STREAM BUTTON) (if (AND NEWVAL (NOT (EQUAL NEWVAL (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.VALUE))))) then (AR.REPLACE.FIELD.VAL OBJ (fetch (SELECTION CH#) of SEL) (SETQ STREAM (WINDOWPROP WINDOW (QUOTE TEXTSTREAM))) NEWVAL) (if (SETQ ASSOC.SUBMENU (IMAGEOBJPROP OBJ (QUOTE AR.ASSOCIATED.SUBMENU))) then (* ; "There is a submenu related to this button (e.g., System -> Subsystem).  Need to clear the submenu value when the main value changed") (if (SETQ BUTTON (AR.FIND.BUTTON STREAM ASSOC.SUBMENU)) then (AR.REPLACE.FIELD.VAL (CAR BUTTON) (CDR BUTTON) STREAM AR.NULL.BUTTON.VALUE) (IMAGEOBJPROP (CAR BUTTON) (QUOTE AR.ASSOCIATED.MENU.VAL) NEWVAL) else (ERROR "Can't find associated submenu button" ASSOC.SUBMENU)))) (AR.RESET.SEL WINDOW)))
)

(AR.BUTTONFN.DOSUBMENU
(LAMBDA (OBJ SEL WINDOW) (* edited%: "30-Aug-84 09:57") (PROG ((STREAM (WINDOWPROP WINDOW (QUOTE TEXTSTREAM))) (ASSOCIATED.MENU.VAL (AR.GET.ASSOCIATED.MENU.VAL OBJ WINDOW)) NEWVAL) (SETQ NEWVAL (MENU (AR.BUTTON.GET.SUBMENU OBJ ASSOCIATED.MENU.VAL))) (if (AND NEWVAL (NOT (EQUAL NEWVAL (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.VALUE))))) then (AR.REPLACE.FIELD.VAL OBJ (fetch (SELECTION CH#) of SEL) STREAM NEWVAL)) (AR.RESET.SEL WINDOW)))
)

(AR.RESET.SEL
(LAMBDA (WINDOW.OR.STREAM) (* ; "Edited 14-Feb-88 02:18 by bvm") (if NIL then (LET ((TOBJ (TEXTOBJ WINDOW.OR.STREAM)) SEL) (TEDIT.SHOWSEL (TEXTSTREAM TOBJ)) (if (SETQ SEL (fetch (TEXTOBJ SEL) of TOBJ)) then (* ; "Manually turn off selection, then mark current selection not set") (replace (SELECTION SET) of SEL with NIL))) else (* ;; "for now, since I can't figure out how to turn off the selection, just put the selection in the first safe <i.e.  unprotected> place") (AR.MAP.BUTTONS WINDOW.OR.STREAM (FUNCTION (LAMBDA (TOBJ OBJ CH#) (* ; "If OBJ is unprotected, set TEdit's selection at its beginning") (if (NOT (IMAGEOBJPROP OBJ (QUOTE AR.PROTECTED.FLG))) then (TEDIT.SETSEL TOBJ (fetch (SELECTION CH#) of (MBUTTON.FIND.NEXT.FIELD TOBJ CH#)) 0 (QUOTE LEFT)) (TEDIT.SHOWSEL (TEXTSTREAM TOBJ)) (* ; "Don't let it be visible") T))))))
)

(AR.REPLACE.FIELD.VAL
(LAMBDA (OBJ CH# WINDOW.OR.STREAM NEWVAL) (* ; "Edited 12-Feb-88 11:40 by bvm") (PROG ((TOBJ (TEXTOBJ WINDOW.OR.STREAM)) (NEWVAL.NCHARS (NCHARS NEWVAL)) (PROTECTEDP (IMAGEOBJPROP OBJ (QUOTE AR.PROTECTED.FLG))) OLDLEN INSERT.CH# SEL) (if PROTECTEDP then (SETQ INSERT.CH# (+ (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.START)) CH#)) (SETQ OLDLEN (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.LEN))) (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.LEN) NEWVAL.NCHARS) (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.VALUE) NEWVAL) elseif (SETQ SEL (MBUTTON.FIND.NEXT.FIELD TOBJ CH#)) then (SETQ INSERT.CH# (fetch (SELECTION CH#) of SEL)) (SETQ OLDLEN (fetch (SELECTION DCH) of SEL)) else (SHOULDNT "Can't find button field")) (TEDIT.DELETE TOBJ INSERT.CH# OLDLEN) (if (> NEWVAL.NCHARS 0) then (TEDIT.INSERT TOBJ (if (NUMBERP NEWVAL) then (MKSTRING NEWVAL) else NEWVAL) INSERT.CH#) (TEDIT.LOOKS TOBJ (CONS (QUOTE PROTECTED) (if PROTECTEDP then (QUOTE (ON)) else (QUOTE (OFF)))) INSERT.CH# NEWVAL.NCHARS))))
)

(AR.GET.ASSOCIATED.MENU.VAL
(LAMBDA (OBJ WINDOW) (* edited%: "30-Aug-84 09:58") (PROG ((BUTTON (AR.FIND.BUTTON (WINDOWPROP WINDOW (QUOTE TEXTSTREAM)) (IMAGEOBJPROP OBJ (QUOTE AR.ASSOCIATED.MENU))))) (if (NULL BUTTON) then (ERROR "Can't find associated menu value" (IMAGEOBJPROP OBJ (QUOTE AR.ASSOCIATED.MENU)))) (RETURN (IMAGEOBJPROP (CAR BUTTON) (QUOTE AR.FIELD.VALUE)))))
)

(AR.BUTTONFN.SELFIELD
(LAMBDA (OBJ SEL WINDOW) (* ; "Edited 16-Feb-88 13:17 by bvm") (* ;; "Button function for text fields--select the current text in delete pending mode") (LET* ((TOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) (FIELD.SEL (MBUTTON.FIND.NEXT.FIELD TOBJ (fetch (SELECTION CH#) of SEL))) FIELD.CH# FIELD.LEN) (TEDIT.SETSEL TOBJ (fetch (SELECTION CH#) of FIELD.SEL) (fetch (SELECTION DCH) of FIELD.SEL) (QUOTE LEFT) T)))
)

(AR.BUTTONFN.OFFER.DEFAULT
(LAMBDA (OBJ SEL WINDOW) (* ; "Edited  4-Aug-88 17:24 by bvm") (* ;; "AR Button function that responds to a click by filling in the default value for the field, pending-delete selected so that you can overwrite it.") (LET* ((TOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) (FIELD.SEL (MBUTTON.FIND.NEXT.FIELD TOBJ (fetch (SELECTION CH#) of SEL))) (FIELD.CH# (fetch (SELECTION CH#) of FIELD.SEL)) (FIELD.LEN (fetch (SELECTION DCH) of FIELD.SEL)) INFO) (if (AND (EQ FIELD.LEN 0) (SETQ INFO (IMAGEOBJPROP OBJ (QUOTE FILLINVALUE))) (OR (NLISTP INFO) (SETQ INFO (EVAL INFO)))) then (* ; "Nothing there yet, so offer default") (TEDIT.INSERT TOBJ INFO FIELD.CH# (QUOTE (PROTECTED OFF))) (SETQ FIELD.LEN (NCHARS INFO))) (TEDIT.SETSEL TOBJ FIELD.CH# FIELD.LEN (QUOTE LEFT) T)))
)

(AR.MAP.BUTTONS
(LAMBDA (WINDOW.OR.STREAM MAPFN DEFAULT) (* ; "Edited 12-Feb-88 10:59 by bvm") (* ;; "Map over the buttons of the form in WINDOW.OR.STREAM, applying MAPFN to each button with args (TEXTOBJ BUTTONOBJ CH#).  Return the value from the first application that returns non-NIL.  Return DEFAULT if all returned NIL.") (bind (TOBJ _ (TEXTOBJ WINDOW.OR.STREAM)) (CH# _ 0) BUTTON RESULT while (SETQ BUTTON (MBUTTON.FIND.NEXT.BUTTON TOBJ (add CH# 1))) when (SETQ RESULT (CL:FUNCALL MAPFN TOBJ (CAR BUTTON) (SETQ CH# (CDR BUTTON)))) do (RETURN RESULT) finally (RETURN DEFAULT)))
)

(AR.FIND.BUTTON
(LAMBDA (WINDOW NAME) (* edited%: "30-Aug-84 09:57") (PROG ((TOBJ (TEXTOBJ WINDOW)) (CH# 0) OBJ BUTTON) (while (PROGN (add CH# 1) (SETQ BUTTON (MBUTTON.FIND.NEXT.BUTTON TOBJ CH#))) do (SETQ OBJ (CAR BUTTON)) (SETQ CH# (CDR BUTTON)) repeatuntil (EQ NAME (IMAGEOBJPROP OBJ (QUOTE MBTEXT)))) (RETURN BUTTON)))
)

(AR.GET.BUTTON.FIELD.AS.TEXT
(LAMBDA (WINDOW BUTTON.NAME) (* ; "Edited 12-Feb-88 11:05 by bvm") (* ;; "Given a button name and an AR form window, grab the value of the named button and return it as a string or symbol.") (OR (AR.MAP.BUTTONS WINDOW (FUNCTION (LAMBDA (TOBJ OBJ CH#) (if (EQ (IMAGEOBJPROP OBJ (QUOTE MBTEXT)) BUTTON.NAME) then (COND ((OR (IMAGEOBJPROP OBJ (QUOTE AR.MENU.LIST)) (IMAGEOBJPROP OBJ (QUOTE AR.SUBMENU.LIST))) (* ; "This is a multiple-choice button. Extract the value from the button itself. ") (OR (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.VALUE)) "")) (T (* ; "This is a text button.  Go looking for the next field and grab it from there.") (MBUTTON.NEXT.FIELD.AS.TEXT TOBJ CH#))))))) (ERROR "Can't find named button" BUTTON.NAME)))
)

(AR.GET.BUTTON.FIELD.SHAPE
(LAMBDA (WINDOW.OR.STREAM BUTTON.NAME) (* ; "Edited 16-Feb-88 11:36 by bvm") (* ;; "Given a button name and an AR form window, return a dotted pair (ch# . length) describing where in the tedit stream the field lives and how long it is.") (OR (AR.MAP.BUTTONS WINDOW.OR.STREAM (FUNCTION (LAMBDA (TOBJ OBJ CH#) (if (EQ (IMAGEOBJPROP OBJ (QUOTE MBTEXT)) BUTTON.NAME) then (if (IMAGEOBJPROP OBJ (QUOTE AR.PROTECTED.FLG)) then (CONS (+ (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.START)) CH#) (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.LEN))) else (LET ((SEL (MBUTTON.FIND.NEXT.FIELD TOBJ CH#))) (if SEL then (CONS (fetch (SELECTION CH#) of SEL) (fetch (SELECTION DCH) of SEL)) else (SHOULDNT "Can't find field for button")))))))) (ERROR "Can't find named button" BUTTON.NAME)))
)

(AR.GET.NUMBER.FIELD
(LAMBDA (FORMWINDOW) (* ; "Edited  5-Aug-88 11:21 by bvm") (* ;; "Return the AR number currently shown in the form's NUMBER field") (MKATOM (AR.GET.BUTTON.FIELD.AS.TEXT (OR (AR.GET.MENU.FROM.MAIN.WINDOW FORMWINDOW) FORMWINDOW) (QUOTE Number%:))))
)
)



(* ; "Handling the command menu")

(DEFINEQ

(AR.FORM.MENU.BUTTONFN
(LAMBDA (OBJ SEL WINDOW) (* ; "Edited  5-Aug-88 11:01 by bvm") (AR.FORM.MENU.ACTIONFN (\TEDIT.PRIMARYW (fetch (SELECTION \TEXTOBJ) of SEL)) (EVAL (CADR (CL:ASSOC (IMAGEOBJPROP OBJ (QUOTE MBTEXT)) AR.FORM.MENU.TITLEMENU.ITEMS)))))
)

(AR.FORM.MENU.ACTIONFN
(LAMBDA (MENUWINDOW OPERATION NUM.FOR.GET OPNAME) (* ; "Edited  5-Aug-88 16:00 by bvm") (ALLOW.BUTTON.EVENTS) (PROG* ((FORMWINDOW (WINDOWPROP MENUWINDOW (QUOTE MAINWINDOW))) (MENUWINDOW.TEXTOBJ (WINDOWPROP MENUWINDOW (QUOTE TEXTOBJ))) (FORMWINDOW.TEXTOBJ (WINDOWPROP FORMWINDOW (QUOTE TEXTOBJ))) SUCCESS ARP BUSY) (AR.PROMPT.CLEAR FORMWINDOW) (if (OR (NOT (WINDOWPROP FORMWINDOW (QUOTE TEXTSTREAM))) (NULL MENUWINDOW.TEXTOBJ) (NULL FORMWINDOW.TEXTOBJ)) then (AR.PROMPT.PRINT FORMWINDOW "AR form munged!! --- Close this AR window and create another") (RETURN)) (if (SETQ BUSY (OR (SETQ ARP (AR.TOBJ.ACTIVEP MENUWINDOW.TEXTOBJ)) (AR.TOBJ.ACTIVEP FORMWINDOW.TEXTOBJ))) then (* ;; "Sometimes this spuriously prints a message, typically on a new window.  Haven't figured out why.") (AR.PROMPT.PRINT FORMWINDOW (if ARP then "AR " else "Edit ") (if (EQ BUSY T) then "operation" else BUSY) " in progress -- please wait") (RETURN)) (CL:UNWIND-PROTECT (PROGN (AR.MARK.ACTIVE MENUWINDOW.TEXTOBJ (OR OPNAME (SETQ OPNAME OPERATION))) (AR.MARK.ACTIVE FORMWINDOW.TEXTOBJ OPNAME) (DSPFILL NIL 72 (QUOTE PAINT) MENUWINDOW) (CLEARW FORMWINDOW) (AR.DISCONNECT.WINDOW FORMWINDOW) (SETQ SUCCESS (NLSETQ (SELECTQ OPERATION (Get (AR.MENU.FN.GET FORMWINDOW NUM.FOR.GET)) (if (LISTP OPERATION) then (* ; "FN + extra arg") (CL:FUNCALL (CAR OPERATION) FORMWINDOW (CADR OPERATION)) else (CL:FUNCALL OPERATION FORMWINDOW))))))) (* ;; "On the way out, make sure we have success/failure indication") (if (NULL SUCCESS) then (AR.PROMPT.PRINT FORMWINDOW T "Command aborted")) (AR.MARK.ACTIVE MENUWINDOW.TEXTOBJ NIL) (AR.MARK.ACTIVE FORMWINDOW.TEXTOBJ NIL) (REDISPLAYW MENUWINDOW) (AR.RESET.SEL FORMWINDOW) (AR.RECONNECT.WINDOW FORMWINDOW) (SCROLLW FORMWINDOW 0.0 0.0)))
)

(AR.FORM.PROGRAMMATIC.GET
(LAMBDA (MENUW AR#) (* ; "Edited  5-Aug-88 11:03 by bvm") (AR.FORM.MENU.ACTIONFN MENUW (QUOTE Get) AR#))
)

(AR.FORM.PROGRAMMATIC.PUT
(LAMBDA (MENUW) (* ; "Edited  5-Aug-88 11:23 by bvm") (AR.FORM.MENU.ACTIONFN MENUW (FUNCTION AR.MENU.FN.PUT)))
)

(AR.DISCONNECT.WINDOW
(LAMBDA (FORMWINDOW) (* mjs "17-Feb-85 16:03") (replace (TEXTOBJ \WINDOW) of (TEXTOBJ (WINDOWPROP FORMWINDOW (QUOTE TEXTSTREAM))) with NIL))
)

(AR.RECONNECT.WINDOW
(LAMBDA (FORMWINDOW) (* ; "Edited 20-Jan-88 16:38 by ckj") (PROG ((TOBJ (TEXTOBJ (WINDOWPROP FORMWINDOW (QUOTE TEXTSTREAM))))) (replace (TEXTOBJ \WINDOW) of TOBJ with (LIST FORMWINDOW)) (replace (LINEDESCRIPTOR NEXTLINE) of (CAR (fetch (TEXTOBJ LINES) of TOBJ)) with NIL) (\TEDIT.MARK.LINES.DIRTY TOBJ 1 (ADD1 (GETEOFPTR (WINDOWPROP FORMWINDOW (QUOTE TEXTSTREAM))))) (TEDIT.UPDATE.SCREEN TOBJ)))
)

(AR.MARK.ACTIVE
(LAMBDA (TOBJ OP) (* edited%: "16-May-84 16:13") (if TOBJ then (replace (TEXTOBJ EDITOPACTIVE) of TOBJ with OP)))
)

(AR.TOBJ.ACTIVEP
(LAMBDA (TOBJ) (* edited%: "16-May-84 16:15") (if (NULL TOBJ) then NIL else (fetch (TEXTOBJ EDITOPACTIVE) of TOBJ)))
)

(AR.FORM.MENU.TITLEMENUFN
(LAMBDA (TEXTSTREAM) (* ; "Edited  5-Aug-88 15:55 by bvm") (LET ((OP (MENU (OR AR.FORM.MENU.TITLEMENU (SETQ AR.FORM.MENU.TITLEMENU (create MENU ITEMS _ AR.FORM.MENU.TITLEMENU.ITEMS TITLE _ "Extra AR Ops" CHANGEOFFSETFLG _ T CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION CL:IDENTITY))))))) (if OP then (AR.FORM.MENU.ACTIONFN (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ TEXTSTREAM))) (if (LISTP OP) then (EVAL (CADR OP)) else OP) NIL (OR (CAR (LISTP OP)) OP)))))
)

(AR.MENU.CR.FN
(LAMBDA (TEXTSTREAM TOBJ) (* ; "Edited  5-Aug-88 11:03 by bvm") (AR.MARK.ACTIVE TOBJ NIL) (AR.FORM.PROGRAMMATIC.GET (\TEDIT.PRIMARYW TOBJ)))
)

(AR.GET.MENU.FROM.MAIN.WINDOW
(LAMBDA (FORMWINDOW) (* ; "Edited  5-Aug-88 11:23 by bvm") (for W in (ATTACHEDWINDOWS FORMWINDOW) when (WINDOWPROP W (QUOTE TEXTOBJ)) do (RETURN W)))
)

(AR.CONFIRM
(LAMBDA (WORDS FORMWINDOW) (* mjs " 4-May-84 14:51") (AR.PROMPT WORDS FORMWINDOW) (MOUSECONFIRM NIL NIL (GETPROMPTWINDOW FORMWINDOW 2)))
)
)



(* ; "CLEAR")

(DEFINEQ

(AR.MENU.FN.CLEAR
(LAMBDA (FORMWINDOW FILL.INS) (* ; "Edited  5-Aug-88 16:03 by bvm") (if (OR (NOT (TEDIT.STREAMCHANGEDP FORMWINDOW)) (AR.CONFIRM "Form has been changed  --- confirm CLEAR" FORMWINDOW)) then (CLEARW FORMWINDOW) (AR.FORM.CLEAR FORMWINDOW FILL.INS) (AR.FORM.SET.TO.EMPTY FORMWINDOW) (AR.PROMPT.PRINT FORMWINDOW :CLEAR (if FILL.INS then "New form cleared" else "Form erased."))))
)

(AR.FORM.CLEAR
(LAMBDA (WINDOW.OR.STREAM FILL.INS NEWFORMP) (* ; "Edited  4-Aug-88 15:24 by bvm") (* ;;; "Create a clean, fresh AR editing window with no data in it but that shown in FILL.INS.  If FILL.INS is T, fill fields that have an INITIALVALUE prop.  If NEWFORMP is true, this is a new form, so don't have to erase old values.") (AR.MAP.BUTTONS WINDOW.OR.STREAM (FUNCTION (LAMBDA (TOBJ OBJ CH#) (* ; "Delete all the fields") (LET (INFO) (if (SETQ INFO (SELECTQ FILL.INS (T (* ; "Use INITIALVALUE prop") (AND (SETQ INFO (IMAGEOBJPROP OBJ (QUOTE INITIALVALUE))) (if (LISTP INFO) then (EVAL INFO) else INFO))) (NIL NIL) (CADR (ASSOC (IMAGEOBJPROP OBJ (QUOTE MBTEXT)) FILL.INS)))) then (* ; "Caller specified initial contents") (AR.REPLACE.FIELD.VAL OBJ CH# TOBJ INFO) elseif (NOT NEWFORMP) then (AR.DELETE.FIELD.VAL OBJ CH# TOBJ)) (* ; "Return NIL so that the iteration continues") NIL)))) (TEDIT.STREAMCHANGEDP (TEXTSTREAM WINDOW.OR.STREAM) T))
)

(AR.FORM.SET.TO.EMPTY
(LAMBDA (FORMWINDOW) (* ; "Edited 22-Feb-88 16:14 by bvm") (* ;; "Sets window properties associated with an empty form.  Usually called in conjunction with AR.FORM.CLEAR") (AR.SET.FORM.NUMBER FORMWINDOW NIL) (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.MAP) NIL) (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.STREAM) NIL) (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.STREAM2) NIL) (WINDOWPROP FORMWINDOW (QUOTE AR.GET/PUT.FILE.NAME) NIL) (WINDOWPROP FORMWINDOW (QUOTE TITLE) "New Bug Report"))
)

(AR.DELETE.FIELD.VAL
(LAMBDA (OBJ CH# WINDOW.OR.STREAM) (* ; "Edited  4-Aug-88 15:22 by bvm") (* ;; " Delete the value associated with the AR form menu button OBJ.") (LET ((TOBJ (TEXTOBJ WINDOW.OR.STREAM)) SEL LEN) (if (IMAGEOBJPROP OBJ (QUOTE AR.PROTECTED.FLG)) then (* ; "Menu objects contain information about their length and position") (if (> (SETQ LEN (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.LEN))) 0) then (TEDIT.DELETE TOBJ (+ (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.START)) CH#) LEN T) (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.LEN) 0) (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.VALUE) AR.NULL.BUTTON.VALUE)) elseif (SETQ SEL (MBUTTON.FIND.NEXT.FIELD TOBJ CH#)) then (* ; "Text fields specified by selection") (if (> (SETQ LEN (fetch (SELECTION DCH) of SEL)) 0) then (TEDIT.DELETE TOBJ (fetch (SELECTION CH#) of SEL) LEN T)) else (SHOULDNT "Can't find field for button"))))
)
)



(* ; "GET")

(DEFINEQ

(AR.MENU.FN.GET
(LAMBDA (FORMWINDOW CURR.NUM) (* ; "Edited  5-Aug-88 11:22 by bvm") (* ;; "Handles GET from the main menu") (OR CURR.NUM (SETQ CURR.NUM (AR.GET.NUMBER.FIELD FORMWINDOW))) (if (NOT (FIXP CURR.NUM)) then (AR.PROMPT.PRINT FORMWINDOW T "Bad number %"" CURR.NUM "%" -- Get aborted") elseif (OR (NULL (TEDIT.STREAMCHANGEDP FORMWINDOW)) (if (AR.CONFIRM "Form has been changed  --- confirm GET" FORMWINDOW) else (AR.PROMPT.PRINT FORMWINDOW T "Get aborted") (* ; "User disconfirmed the Get") NIL)) then (AR.GET.AR FORMWINDOW CURR.NUM)))
)

(AR.GET.AR
(LAMBDA (FORMWINDOW NUM/OR/FILE FORMSTREAM) (* ; "Edited  4-Aug-88 15:14 by bvm") (* ;; "Get an AR into the AR editing window.  FORMSTREAM defaults to the window's tedit stream, but can be explicit if this is a new window.  Returns one of: NIL = success; XCL:FILE-NOT-FOUND = no such ar; else some error message (and the current form has been cleared).") (AR.PROMPT.PRINT FORMWINDOW T "Retrieving " AR.IDENTIFICATION.STRING " " NUM/OR/FILE " ...") (CL:MULTIPLE-VALUE-BIND (MAP CONDITION) (AR.FETCH.AND.PARSE.AR NUM/OR/FILE (AR.GET.SCRATCH.STREAM FORMWINDOW)) (if (OR CONDITION (PROGN (* ; "Now fill in the textstream with the appropriate fields from the AR.") (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.MAP) MAP) (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.STREAM2) NIL) (CL:MULTIPLE-VALUE-BIND (IGNORE C) (IGNORE-ERRORS (AR.TEXTSTREAM.LOAD FORMWINDOW FORMSTREAM)) (SETQ CONDITION C)))) then (* ; "Got an error") (CL:TYPECASE CONDITION (XCL:FILE-NOT-FOUND (AR.PROMPT.PRINT FORMWINDOW T AR.IDENTIFICATION.STRING " " NUM/OR/FILE " doesn't exist -- Get aborted") (QUOTE XCL:FILE-NOT-FOUND)) (T (* ; "Other unknown error--form is now inconsistent, since we have smashed the old AR's scratch stream, so reset to blank form") (AR.PROMPT.PRINT FORMWINDOW T (CL:FORMAT NIL "Failed while loading ~A ~A: ~A" AR.IDENTIFICATION.STRING NUM/OR/FILE CONDITION)) (AR.FORM.CLEAR (OR FORMSTREAM FORMWINDOW) T) (AR.FORM.SET.TO.EMPTY FORMWINDOW) T)) else (LET ((ARNUM (IMAGEOBJPROP (CAR (AR.FIND.BUTTON (OR FORMSTREAM FORMWINDOW) (QUOTE Number%:))) (QUOTE AR.FIELD.VALUE)))) (if (NUMBERP NUM/OR/FILE) then (if (NOT (= ARNUM NUM/OR/FILE)) then (CL:ERROR "Retrieved file for ~A# ~D, but file thinks it is ~A" AR.IDENTIFICATION.STRING NUM/OR/FILE ARNUM)) (AR.SET.FORM.NUMBER FORMWINDOW NUM/OR/FILE) (WINDOWPROP FORMWINDOW (QUOTE AR.GET/PUT.FILE.NAME) NIL) else (* ; "Set number according to whether the saved ar was numbered.") (AR.SET.FORM.NUMBER FORMWINDOW (SETQ ARNUM (FIXP ARNUM)))) (WINDOWPROP FORMWINDOW (QUOTE TITLE) (CONCAT "Editing " AR.IDENTIFICATION.STRING " " (OR ARNUM NUM/OR/FILE))) (AR.PROMPT.PRINT FORMWINDOW T AR.IDENTIFICATION.STRING " " NUM/OR/FILE " retrieved") (* ; "Return NIL on success") NIL))))
)

(AR.FETCH.AND.PARSE.AR
(LAMBDA (NUM/OR/FILE SCRATCH.STREAM INDEX.FIELDS DONTRESET) (* ; "Edited 21-Jul-88 14:57 by bvm") (* ;; "Read AR file (or number) into SCRATCH.STREAM and returns its parse (the %"scratch map%") for each of INDEX.FIELDS, or for all fields if NIL.  Returns a CONDITION as second value if there was an error.  If DONTRESET is true, then doesn't reset SCRATCH.STREAM, but starts copying at its current position.") (IGNORE-ERRORS (LET ((*UPPER-CASE-FILE-NAMES* NIL) ARSTREAM) (* ; "Open the AR file and read its contents into a scratch stream, stored on the window") (CL:UNWIND-PROTECT (PROGN (* ; "Open the AR and copy it into the scratch stream") (SETQ ARSTREAM (OPENSTREAM (COND ((NUMBERP NUM/OR/FILE) (AR.GET.FILENAME NUM/OR/FILE NIL)) (T NUM/OR/FILE)) (QUOTE INPUT) (QUOTE OLD))) (OR DONTRESET (SETFILEPTR SCRATCH.STREAM 0)) (AR.COPY.AND.INDEX.AR ARSTREAM SCRATCH.STREAM INDEX.FIELDS)) (COND ((AND ARSTREAM (OPENP ARSTREAM)) (CLOSEF ARSTREAM)))))))
)

(AR.SET.FORM.NUMBER
(LAMBDA (FORMWINDOW N) (* ; "Edited  5-Aug-88 16:10 by bvm") (* ;; "Record N as the number of the AR currently living in FORMWINDOW") (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.NUMBER) N) (LET ((ICON (WINDOWPROP FORMWINDOW (QUOTE ICONWINDOW)))) (* ; "Fix icon label if there is one") (AND ICON (ICONW.TITLE ICON (if N then (MKSTRING N) else "")))) (* ; "Change the contents of the %"Number:%" button in the menu ") (LET ((MENUW (AR.GET.MENU.FROM.MAIN.WINDOW FORMWINDOW)) (BUTTON.NAME (QUOTE Number%:)) BUTTON) (if (SETQ BUTTON (AR.FIND.BUTTON MENUW BUTTON.NAME)) then (if N then (MBUTTON.SET.FIELD (TEXTOBJ MENUW) (QUOTE Number%:) N) else (* ; "Bug in MBUTTON.SET.FIELD won't let me replace it with null string") (AR.DELETE.FIELD.VAL (CAR BUTTON) (CDR BUTTON) MENUW)) else (ERROR "Can't find named button" BUTTON.NAME))))
)

(AR.GET.SCRATCH.STREAM
(LAMBDA (WINDOW) (* ; "Edited 17-Feb-88 15:07 by bvm") (* ;; "Return a nodircore stream, resuing the one on WINDOW if it's there.") (OR (WINDOWPROP WINDOW (QUOTE AR.FORM.SCRATCH.STREAM)) (LET ((S (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (WINDOWPROP WINDOW (QUOTE AR.FORM.SCRATCH.STREAM) S) S)))
)

(AR.COPY.AND.INDEX.AR
(LAMBDA (ARSTREAM SCRATCH.STREAM INDEX.FIELDS) (* ; "Edited 15-Feb-88 11:43 by bvm") (* ;; "Read thru an AR file, copying its contents to SCRATCH.STREAM, and building an index of where each field's data appears in the scratch file.  The index is a list of entries: (Field-Name Starting-Fileptr Length)") (bind INDEX CHAR until (EOFP ARSTREAM) do (BLOCK) (LET ((FIELD.NAME (PACKC (collect (SETQ CHAR (BIN ARSTREAM)) repeatuntil (EQ CHAR (CHARCODE %:))))) (START (GETFILEPTR SCRATCH.STREAM))) (* ;; "FIELD.NAME contains the name of the next field, e.g. %"Subject:%" -- yes, including the colon.") (BIN ARSTREAM) (* ; "skip extra space after ':'") (COND ((OR (NLISTP INDEX.FIELDS) (MEMB FIELD.NAME INDEX.FIELDS)) (* ; "Only gather fields that the caller asked about.") (do (* ;; "Copy the field's CONTENTS to the scratch file -- everything up to the next CR.") (BOUT SCRATCH.STREAM (SELCHARQ (SETQ CHAR (BIN ARSTREAM)) (%' (* ; "' is used to escape special characters.") (BIN ARSTREAM)) (CR (* ; "There best be TWO CR's at the end of the field") (RETURN (OR (EQ (BIN ARSTREAM) (CHARCODE CR)) (AR.MALFORMED.AR ARSTREAM)))) CHAR))) (* ;; "INDEX is a list of entries like (FieldName StartingLoc Length) for each field.") (push INDEX (LIST FIELD.NAME START (- (GETFILEPTR SCRATCH.STREAM) START)))) (T (* ; "Otherwise, skip over this field -- it's of no interest.") (do (SELCHARQ (SETQ CHAR (BIN ARSTREAM)) (%' (BLOCK) (BIN ARSTREAM)) (CR (RETURN (OR (EQ (BIN ARSTREAM) (CHARCODE CR)) (AR.MALFORMED.AR ARSTREAM)))) CHAR))))) finally (\SETEOFPTR SCRATCH.STREAM (GETFILEPTR SCRATCH.STREAM)) (RETURN INDEX)))
)

(AR.MALFORMED.AR
(LAMBDA (ARSTREAM) (* ; "Edited 15-Feb-88 11:42 by bvm") (CL:ERROR "Malformed AR file")))

(AR.TEXTSTREAM.LOAD
(LAMBDA (FORMWINDOW FORMSTREAM) (* ; "Edited 22-Feb-88 16:46 by bvm") (* ;; "Load the ar whose map is in FORMWINDOW into FORMSTREAM, which defaults to the textstream in the window.") (COND ((NOT FORMSTREAM) (* ; "Take stream from window, and clear its old contents first") (AR.FORM.CLEAR (SETQ FORMSTREAM (WINDOWPROP FORMWINDOW (QUOTE TEXTSTREAM)))))) (PROG ((TOBJ (TEXTOBJ FORMSTREAM)) (SCRATCH.STREAM (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.STREAM))) (SCRATCH.MAP (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.MAP))) (CH# 0) FIELD.LEN OBJ BUTTON PROTECT.FIELD.FLG FIELD.CH# SEL SCRATCH.MAP.SPEC SCRATCH.PTR) (while (SETQ BUTTON (MBUTTON.FIND.NEXT.BUTTON TOBJ (add CH# 1))) do (* ;; "Run thru the buttons in the AR form, filling in data for each one.") (BLOCK) (SETQ OBJ (CAR BUTTON)) (SETQ CH# (CDR BUTTON)) (SETQ PROTECT.FIELD.FLG (IMAGEOBJPROP OBJ (QUOTE AR.PROTECTED.FLG))) (COND (PROTECT.FIELD.FLG (SETQ FIELD.CH# (+ (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.START)) CH#))) ((SETQ SEL (MBUTTON.FIND.NEXT.FIELD TOBJ CH#)) (SETQ FIELD.CH# (fetch (SELECTION CH#) of SEL))) (T (HELP "Can't find field for button"))) (SETFILEPTR FORMSTREAM (SUB1 FIELD.CH#)) (SETQ SCRATCH.MAP.SPEC (ASSOC (IMAGEOBJPROP OBJ (QUOTE MBTEXT)) SCRATCH.MAP)) (COND ((NULL SCRATCH.MAP.SPEC) (* ; "Perhaps a new field has been added to AREdit, but this is an old ar.") (PRINTOUT PROMPTWINDOW T "AR has no " (IMAGEOBJPROP OBJ (QUOTE MBTEXT)) " field") (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.VALUE) NIL)) (T (* ; "Copy the field's contents from the scratch file into the form.  Map entry is (field pointer length)") (SETQ FIELD.LEN (CADDR SCRATCH.MAP.SPEC)) (COND ((> FIELD.LEN 0) (TEDIT.FAST.RAW.INCLUDE FORMSTREAM SCRATCH.STREAM (SETQ SCRATCH.PTR (CADR SCRATCH.MAP.SPEC)) (+ SCRATCH.PTR FIELD.LEN) FIELD.CH#) (* ; "And protect the contents from tampering if protected") (TEDIT.LOOKS FORMSTREAM (COND (PROTECT.FIELD.FLG (QUOTE (PROTECTED ON))) (T (QUOTE (PROTECTED OFF)))) FIELD.CH# FIELD.LEN))) (COND (PROTECT.FIELD.FLG (* ; "Mostly menu buttons") (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.LEN) FIELD.LEN) (if (OR (EQ (CAR SCRATCH.MAP.SPEC) (QUOTE Number%:)) (SELECTQ PROTECT.FIELD.FLG ((MENU SUBMENU) T) NIL)) then (* ; "These guys want to know the symbolic value stored in the field") (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.VALUE) (if (> FIELD.LEN 0) then (PACKC (AR.READ.BYTES SCRATCH.STREAM FIELD.LEN SCRATCH.PTR)) else AR.NULL.BUTTON.VALUE)))))))) (AR.RESET.SEL FORMSTREAM) (TEDIT.STREAMCHANGEDP FORMSTREAM T)))
)

(AR.REPLACE.FILL.INS
(LAMBDA (STREAM.OR.WINDOW FILL.INS) (* ; "Edited 12-Feb-88 18:42 by bvm") (for X in FILL.INS bind (FORMSTREAM _ (TEXTSTREAM STREAM.OR.WINDOW)) BUTTON do (BLOCK) (if (SETQ BUTTON (AR.FIND.BUTTON FORMSTREAM (CAR X))) then (AR.REPLACE.FIELD.VAL (CAR BUTTON) (CDR BUTTON) FORMSTREAM (CADR X)))))
)
)



(* ; "PUT")

(DEFINEQ

(AR.MENU.FN.PUT
(LAMBDA (FORMWINDOW) (* ; "Edited  4-Aug-88 12:35 by bvm") (PROG ((*PRINT-BASE* 10) FILE CHECK.VALUE EDIT.CHANGES.LIST EDIT.CHANGES.STRING EDIT.CHANGES.TEXT CURR.NUM DT OPERATION USER) (if (AND (NOT (TEDIT.STREAMCHANGEDP FORMWINDOW)) (NULL (WINDOWPROP FORMWINDOW (QUOTE AR.GET/PUT.FILE.NAME))) (NOT (AR.CONFIRM "Form has NOT been changed  --- confirm PUT" FORMWINDOW))) then (AR.PROMPT.PRINT FORMWINDOW T "Put aborted") (RETURN)) (SETQ EDIT.CHANGES.STRING (CONCAT (SETQ USER (AR.USERNAME)) " " (SETQ DT (DATE)))) (if (SETQ CURR.NUM (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.NUMBER))) then (SETQ OPERATION (QUOTE EDIT)) (* ; "Editing an existing AR") (SETQ EDIT.CHANGES.LIST (AR.FIND.EDIT.CHANGES FORMWINDOW)) (* ; "A list of (field x), where x is either an old/new value pair, or the original length of the field (now smashed).") (LET ((TSTREAM (TEXTSTREAM FORMWINDOW)) (BUTTON (AR.FIND.BUTTON FORMWINDOW (QUOTE Disposition%:))) INSERTION DISPLEN) (* ; "BUTTON = (obj . ch#)") (SETQ EDIT.CHANGES.STRING (CONCATLIST (CONS EDIT.CHANGES.STRING (for X in EDIT.CHANGES.LIST join (LIST* " " (CAR X) (if (FIXP (CADR X)) then (push EDIT.CHANGES.TEXT X) NIL else (* ; "Parenthetically, the old and new values") (LIST (CADR X)))))))) (TEDIT.INSERT TSTREAM (SETQ INSERTION (CONCAT "
[" EDIT.CHANGES.STRING "]")) (+ (CDR BUTTON) (IMAGEOBJPROP (CAR BUTTON) (QUOTE AR.FIELD.START)) (SETQ DISPLEN (IMAGEOBJPROP (CAR BUTTON) (QUOTE AR.FIELD.LEN)))) (QUOTE (PROTECTED ON)) T) (IMAGEOBJPROP (CAR BUTTON) (QUOTE AR.FIELD.LEN) (+ DISPLEN (NCHARS INSERTION))) (AR.NOTE.FIELD.CHANGED FORMWINDOW BUTTON)) (AR.REPLACE.FILL.INS FORMWINDOW (BQUOTE ((Edit-By%: (\, USER)) (Edit-Date%: (\, DT))))) (AR.NOTE.FIELD.CHANGED FORMWINDOW (AR.FIND.BUTTON FORMWINDOW (QUOTE Edit-By%:))) (AR.NOTE.FIELD.CHANGED FORMWINDOW (AR.FIND.BUTTON FORMWINDOW (QUOTE Edit-Date%:))) else (SETQ OPERATION (QUOTE SUBMIT)) (AR.PROMPT.PRINT FORMWINDOW T "Getting Submit number...") (if (NULL (SETQ CURR.NUM (AR.GET.SUBMIT.NUM FORMWINDOW))) then (AR.PUT.FAILED "Can't get AR submit number --- Put Aborted --- Try again" FORMWINDOW) (RETURN)) (AR.PROMPT.PRINT FORMWINDOW " = " CURR.NUM) (AR.REPLACE.FILL.INS FORMWINDOW (BQUOTE ((Number%: (\, CURR.NUM)) (Date%: (\, DT))))) (* ; "make sure that no one tries accessing the scratch stream") (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.MAP) NIL)) (if (SETQ CHECK.VALUE (AR.CHECK.FIELDS FORMWINDOW)) then (AR.PUT.FAILED (CONCAT "Bad bug report form: " CHECK.VALUE " --- Put Aborted") FORMWINDOW) (RETURN)) (if (NULL (NLSETQ (AR.UPDATE.AR.INFO FORMWINDOW OPERATION CURR.NUM EDIT.CHANGES.STRING))) then (AR.PUT.FAILED "Cannot update TDS file --- Put aborted -- try again" FORMWINDOW) (RETURN)) (CLEARW FORMWINDOW) (AR.PROMPT.PRINT FORMWINDOW T (SELECTQ OPERATION (SUBMIT "Submitting ") "Saving ") AR.IDENTIFICATION.STRING " " CURR.NUM " ...") (if (PROG1 (AR.FORM.SAVE FORMWINDOW CURR.NUM) (TEDIT.STREAMCHANGEDP FORMWINDOW T)) then (AR.SET.FORM.NUMBER FORMWINDOW CURR.NUM) (WINDOWPROP FORMWINDOW (QUOTE TITLE) (CONCAT "Saved " AR.IDENTIFICATION.STRING " " CURR.NUM)) (if (EQ OPERATION (QUOTE EDIT)) then (AR.SEND.MESSAGE FORMWINDOW (QUOTE EDIT) CURR.NUM EDIT.CHANGES.STRING EDIT.CHANGES.TEXT) else (AR.SEND.MESSAGE FORMWINDOW (QUOTE SUBMIT) CURR.NUM)) else (AR.PUT.FAILED "Unknown bug -- AR not saved -- try again" FORMWINDOW))))
)

(AR.MENU.FN.PUT&GET
(LAMBDA (FORMWINDOW) (* ; "Edited  5-Aug-88 15:56 by bvm") (LET ((NUM (AR.READ.NUMBER))) (AR.MENU.FN.PUT FORMWINDOW) (AR.MENU.FN.GET FORMWINDOW NUM)))
)

(AR.MENU.FN.PUT&GETNEXT
(LAMBDA (FORMWINDOW) (* ; "Edited  5-Aug-88 15:57 by bvm") (AR.MENU.FN.PUT FORMWINDOW) (AR.GET.NEXT FORMWINDOW))
)

(AR.FORM.SAVE
(LAMBDA (FORMWINDOW FILENAME) (* ; "Edited 20-Jul-88 17:09 by bvm") (* ;; "Save the contents of an AR window into an AR file.") (RESETLST (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (FORMSTREAM (TEXTSTREAM FORMWINDOW)) (TOBJ (TEXTOBJ FORMWINDOW)) (CH# 0) BUTTON OUTSTREAM BUTTON.OBJ FIELD.START FIELD.LEN SEL TOBJ NUM) (if (FIXP FILENAME) then (SETQ NUM FILENAME) (SETQ FILENAME (AR.GET.FILENAME FILENAME T))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (OUTSTREAM) (COND (RESETSTATE (* ; "Cleanup after faulty put") (COND ((OPENP OUTSTREAM) (CLOSEF OUTSTREAM))) (DELFILE (FULLNAME OUTSTREAM)) (AR.PROMPT.PRINT FORMWINDOW T "SAVE ERROR - bad bug report file " (FULLNAME OUTSTREAM) " deleted"))))) (SETQ OUTSTREAM (OPENSTREAM FILENAME (QUOTE OUTPUT) (QUOTE NEW))))) (if (NOT NUM) then (AR.PROMPT.PRINT FORMWINDOW T "Writing " (FULLNAME OUTSTREAM) " ...")) (LINELENGTH MAX.SMALLP OUTSTREAM) (* ; "Don't get spurious CR's in output") LP (BLOCK) (COND ((NULL (SETQ BUTTON (MBUTTON.FIND.NEXT.BUTTON TOBJ (add CH# 1)))) (AR.PROMPT.PRINT FORMWINDOW " done") (RETURN (CLOSEF OUTSTREAM)))) (SETQ CH# (CDR BUTTON)) (SETQ BUTTON.OBJ (CAR BUTTON)) (PRIN3 (IMAGEOBJPROP BUTTON.OBJ (QUOTE MBTEXT)) OUTSTREAM) (* ; "Print out the name of the field") (* ; "Because the ARFile->WIndow code does its own char-by-char reading, we DON'T want a readtable-driven print here.") (BOUT OUTSTREAM (CHARCODE SPACE)) (COND ((IMAGEOBJPROP BUTTON.OBJ (QUOTE AR.PROTECTED.FLG)) (SETQ FIELD.START (+ (IMAGEOBJPROP BUTTON.OBJ (QUOTE AR.FIELD.START)) CH#)) (SETQ FIELD.LEN (IMAGEOBJPROP BUTTON.OBJ (QUOTE AR.FIELD.LEN)))) (T (SETQ SEL (MBUTTON.FIND.NEXT.FIELD TOBJ CH#)) (SETQ FIELD.START (fetch (SELECTION CH#) of SEL)) (SETQ FIELD.LEN (fetch (SELECTION DCH) of SEL)))) (SETFILEPTR FORMSTREAM (SUB1 FIELD.START)) (for X from 1 to FIELD.LEN bind C WARNED do (SETQ C (BIN FORMSTREAM)) (COND ((NOT (FIXP C)) (if (NEQ WARNED (SETQ WARNED (IMAGEOBJPROP BUTTON.OBJ (QUOTE MBTEXT)))) then (AR.PROMPT.PRINT FORMWINDOW " [Image object(s) in " WARNED " field discarded.]"))) ((> C \MAXTHINCHAR) (* ; "Format doesn't accommodate NS chars yet") (if (NEQ WARNED (SETQ WARNED (IMAGEOBJPROP BUTTON.OBJ (QUOTE MBTEXT)))) then (AR.PROMPT.PRINT FORMWINDOW " [NS chars in " WARNED " field discarded.]")) (BOUT OUTSTREAM (CHARCODE *))) ((FMEMB C (CHARCODE (CR %: "'"))) (BLOCK) (BOUT OUTSTREAM (CHARCODE "'")) (BOUT OUTSTREAM C)) (T (BOUT OUTSTREAM C)))) (TERPRI OUTSTREAM) (TERPRI OUTSTREAM) (GO LP))))
)

(AR.GET.SUBMIT.NUM
(LAMBDA (FORMWINDOW DONTINCREMENT) (* ; "Edited 20-Jul-88 16:39 by bvm") (* ;; "Obtains and increments (unless DONTINCREMENT true) the number of the next ar to be submitted.  Returns NIL on various failures.") (from 1 to AR.FILE.TRIES bind SUBMIT.NUM.FILE VAL CURR.NEXT.NUM CONDITION *UPPER-CASE-FILE-NAMES* do (CL:MULTIPLE-VALUE-SETQ (SUBMIT.NUM.FILE CONDITION) (IGNORE-ERRORS (OPENSTREAM AR.SUBMIT.NUM.FILE.NAME (QUOTE BOTH) (QUOTE OLD) (QUOTE ((DON'T.CACHE T) (DON'TCACHE T)))))) (if SUBMIT.NUM.FILE then (* ; "Got the file.  Read the number therein and run away") (SETQ VAL (NLSETQ (PROGN (SETFILEPTR SUBMIT.NUM.FILE 0) (SETQ CURR.NEXT.NUM (READ SUBMIT.NUM.FILE FILERDTBL)) (if (NOT (FIXP CURR.NEXT.NUM)) then (ERROR!)) (if (NOT DONTINCREMENT) then (SETFILEPTR SUBMIT.NUM.FILE 0) (PRINT (ADD1 CURR.NEXT.NUM) SUBMIT.NUM.FILE FILERDTBL))))) (CLOSEF SUBMIT.NUM.FILE) (RETURN (AND VAL CURR.NEXT.NUM)) else (CL:TYPECASE CONDITION (XCL:FILE-NOT-FOUND (* ; "Doesn't even exist?") (AR.PROMPT.PRINT FORMWINDOW T "Can't find submit number file " AR.SUBMIT.NUM.FILE.NAME) (RETURN NIL)) (T (AR.PROMPT.PRINT FORMWINDOW T (CL:FORMAT NIL "~A" CONDITION) " --- please wait") (DISMISS 5000)))) finally (AR.PROMPT.PRINT FORMWINDOW T "Gave up trying to open submit number file--try again later")))
)

(AR.FIND.EDIT.CHANGES
(LAMBDA (FORMWINDOW) (* ; "Edited 16-Feb-88 12:33 by bvm") (* ;; "Find everything that's changed between the original ar and what's currently there, by comparing the tedit stream with the scratch file.") (PROG ((SCRATCH.STREAM (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.STREAM))) (SCRATCH.MAP (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.MAP))) (FORMSTREAM (WINDOWPROP FORMWINDOW (QUOTE TEXTSTREAM))) (CH# 0) SECOND.SCRATCH OBJ BUTTON BUTTON.NAME FIELD.CH# FIELD.LEN TOBJ SCRATCH.MAP.SPEC ORIGSTREAM ORIGPTR ORIGLEN EDIT.CHANGES PROTECTEDFLG SEL) (if (NULL SCRATCH.MAP) then (RETURN NIL)) (SETQ TOBJ (TEXTOBJ FORMSTREAM)) (while (SETQ BUTTON (MBUTTON.FIND.NEXT.BUTTON TOBJ (add CH# 1))) do (BLOCK) (SETQ OBJ (CAR BUTTON)) (SETQ CH# (CDR BUTTON)) (SETQ BUTTON.NAME (IMAGEOBJPROP OBJ (QUOTE MBTEXT))) (if (SETQ SCRATCH.MAP.SPEC (ASSOC BUTTON.NAME SCRATCH.MAP)) then (SETQ ORIGPTR (CADR SCRATCH.MAP.SPEC)) (SETQ ORIGLEN (CADDR SCRATCH.MAP.SPEC)) (SETQ ORIGSTREAM (if (NULL (CDDDR SCRATCH.MAP.SPEC)) then SCRATCH.STREAM else (OR SECOND.SCRATCH (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.STREAM2))))) else (* ; "note that you default to a zero-length field if it is not specified in the file") (SETQ ORIGPTR (SETQ ORIGLEN 0)) (SETQ ORIGSTREAM SCRATCH.STREAM)) (if (SETQ PROTECTEDFLG (IMAGEOBJPROP OBJ (QUOTE AR.PROTECTED.FLG))) then (SETQ FIELD.CH# (+ (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.START)) CH#)) (SETQ FIELD.LEN (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.LEN))) elseif (SETQ SEL (MBUTTON.FIND.NEXT.FIELD TOBJ CH#)) then (SETQ FIELD.CH# (fetch (SELECTION CH#) of SEL)) (SETQ FIELD.LEN (fetch (SELECTION DCH) of SEL)) else (SHOULDNT "Can't find field for button")) (if (OR (NOT (= FIELD.LEN ORIGLEN)) (AND (NEQ FIELD.LEN 0) (AR.PIECE.CHANGED TOBJ FORMSTREAM FIELD.CH# ORIGSTREAM ORIGPTR ORIGLEN))) then (* ; "we know that the current value of the field is not equal to the value when loaded") (push EDIT.CHANGES (LIST BUTTON.NAME (if (OR (EQ BUTTON.NAME (QUOTE Attn%:)) (MEMB PROTECTEDFLG (QUOTE (MENU SUBMENU)))) then (* ; "Note the old and new values") (CONCATCODES (CONS (CHARCODE "(") (NCONC (AR.READ.BYTES ORIGSTREAM ORIGLEN ORIGPTR) (APPEND (CHARCODE (- >))) (AR.READ.BYTES FORMSTREAM FIELD.LEN (SUB1 FIELD.CH#)) (CHARCODE (")"))))) else (* ; "Just note the old length, so we can retrieve what's new (maybe)") ORIGLEN))) (if (< FIELD.LEN (UNFOLD BYTESPERPAGE 2)) then (* ; "Note the field's new contents for next time around.  Don't bother for long fields, since that can be expensive.") (AR.NOTE.FIELD.CHANGED FORMWINDOW BUTTON FIELD.CH# FIELD.LEN)))) (RETURN (DREVERSE EDIT.CHANGES))))
)

(AR.NOTE.FIELD.CHANGED
(LAMBDA (FORMWINDOW BUTTON FIELD.CH# FIELD.LEN) (* ; "Edited 22-Feb-88 15:46 by bvm") (* ;; "Updates FORMWINDOW's %"original%" AR scratch stream with the contents of the new field, so that if we put again, we don't get the field looking changed twice.  If FIELD.CH# is NIL, we'll compute it from the button, which must be an unprotected button.") (PROG ((SCRATCH.STREAM (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.STREAM2))) (SCRATCH.MAP (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.MAP))) (FORMSTREAM (WINDOWPROP FORMWINDOW (QUOTE TEXTSTREAM))) (OBJ (CAR BUTTON)) SEL) (if (NULL SCRATCH.MAP) then (* ; "New AR without map, nothing interesting to do.") (RETURN)) (if (NOT SCRATCH.STREAM) then (* ; "Need secondary scratch stream, because the primary scratch stream is being used to back the TEdit stream--the COPYBYTES below would have real trouble.") (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.SCRATCH.STREAM2) (SETQ SCRATCH.STREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))))) (if (NOT FIELD.CH#) then (if (IMAGEOBJPROP OBJ (QUOTE AR.PROTECTED.FLG)) then (SETQ FIELD.CH# (IPLUS (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.START)) (CDR BUTTON))) (SETQ FIELD.LEN (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.LEN))) else (SETQ SEL (MBUTTON.FIND.NEXT.FIELD (TEXTOBJ FORMSTREAM) (CDR BUTTON))) (SETQ FIELD.CH# (fetch (SELECTION CH#) of SEL)) (SETQ FIELD.LEN (fetch (SELECTION DCH) of SEL)))) (SETFILEPTR SCRATCH.STREAM -1) (NLSETQ (* ; "Wrap in NLSETQ in case the COPYBYTES complains about non-ascii in the text stream") (PUTASSOC (IMAGEOBJPROP OBJ (QUOTE MBTEXT)) (PROG1 (LIST* (GETFILEPTR SCRATCH.STREAM) FIELD.LEN T) (SETFILEPTR FORMSTREAM (SUB1 FIELD.CH#)) (COPYBYTES FORMSTREAM SCRATCH.STREAM FIELD.LEN)) SCRATCH.MAP))))
)

(AR.SEND.MESSAGE
(LAMBDA (FORMWINDOW OPERATION NUM EDIT.CHANGES.STRING EDIT.CHANGES.TEXT) (* ; "Edited  5-Aug-88 17:57 by bvm") (* ;; "Send a message describing what just got done to this AR.") (PROG ((FORMSTREAM (TEXTSTREAM FORMWINDOW)) RECIPIENTS TXT SUBM TEM) (COND (AR.NO.MESSAGE.FLG (RETURN)) ((OR (NOT (GETD (QUOTE LAFITEMODE))) (NOT (LAFITEMODE))) (PROMPTPRINT "Can't send AR message -- LAFITE not turned on") (RETURN))) (SETQ SUBM (AR.GET.BUTTON.FIELD.AS.TEXT FORMSTREAM (QUOTE Submitter%:))) (SETQ RECIPIENTS (AR.GET.BUTTON.FIELD.AS.TEXT FORMSTREAM (QUOTE Attn%:))) (COND ((EQUAL RECIPIENTS "") (SETQ RECIPIENTS (if (OR (NEQ OPERATION (QUOTE EDIT)) (EQUAL SUBM "")) then ">>Recipients<<" else (PROG1 SUBM (SETQ SUBM "")))))) (SETQ TXT (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (* ; "Make scratch core file--faster than starting with TEdit.") (LINELENGTH MAX.SMALLP TXT) (LET ((*PRINT-BASE* 10)) (printout TXT "Subject: " (COND ((EQ OPERATION (QUOTE SUBMIT)) "Submitt") (T "Edit")) "ed " AR.IDENTIFICATION.STRING " " (OR NUM "<unknown number>"))) (printout TXT ": ") (AR.COPY.BUTTON.FIELD FORMSTREAM TXT (QUOTE Subject%:)) (printout TXT T "To: " RECIPIENTS T) (COND ((AND (EQ OPERATION (QUOTE EDIT)) (NOT (EQUAL SUBM ""))) (* ; "CC the submitter on edits.") (PRINTOUT TXT "cc: " SUBM T))) (TERPRI TXT) (COND ((EQ OPERATION (QUOTE SUBMIT)) (* ; "Display the ars description, plus any other interesting fields") (AR.COPY.BUTTON.FIELD FORMSTREAM TXT (QUOTE Description%:)) (TERPRI TXT) (for FIELD in AR.INTERESTING.SUBMIT.FIELDS do (AR.COPY.BUTTON.FIELD FORMSTREAM TXT FIELD T))) (T (printout TXT "[" EDIT.CHANGES.STRING "]" T) (if EDIT.CHANGES.TEXT then (* ;; "Some text fields changed, might be nice to show them here.  EDIT.CHANGES.TEXT is a list of (field oldlength)") (if (SETQ TEM (ASSOC (QUOTE Description%:) EDIT.CHANGES.TEXT)) then (* ; "Show appended description") (TERPRI TXT) (AR.COPY.BUTTON.FIELD FORMSTREAM TXT (QUOTE Description%:) NIL (CADR TEM)) (TERPRI TXT)) (for PAIR in EDIT.CHANGES.TEXT when (AND (EQ (CADR PAIR) 0) (NEQ (CAR PAIR) (QUOTE Description%:))) do (* ; "Display any brand new fields") (AR.COPY.BUTTON.FIELD FORMSTREAM TXT (CAR PAIR) T))))) (TERPRI TXT) (ADD.PROCESS (BQUOTE ((\, (FUNCTION \SENDMESSAGE)) (QUOTE (\, (OPENTEXTSTREAM TXT NIL NIL NIL (LIST (QUOTE FONT) LAFITEEDITORFONT)))) (QUOTE (LEAVETTY T)))) (QUOTE NAME) (QUOTE MESSAGESENDER))))
)

(AR.COPY.BUTTON.FIELD
(LAMBDA (FORMSTREAM OUTSTREAM BUTTON.NAME LABEL START) (* ; "Edited 23-Feb-88 12:30 by bvm") (* ;; "Copy the contents of the named field from FORMSTREAM to OUTSTREAM, starting at offset START (default zero).  If LABEL is true, starts a new line and prints the button name in front of the text.") (DESTRUCTURING-BIND (CH# . LEN) (AR.GET.BUTTON.FIELD.SHAPE FORMSTREAM BUTTON.NAME) (if START then (add CH# START) (SETQ LEN (- LEN START))) (if (> LEN 0) then (SETFILEPTR FORMSTREAM (SUB1 CH#)) (if LABEL then (PRINTOUT OUTSTREAM T BUTTON.NAME "  ") else (* ; "Let's filter leading cr's") (bind CH while (PROGN (SETQ LEN (SUB1 LEN)) (EQ (SETQ CH (BIN FORMSTREAM)) (CHARCODE CR))) do (if (<= LEN 0) then (* ; "Field entirely cr's!") (RETURN)) finally (if (FIXP CH) then (\OUTCHAR OUTSTREAM CH)))) (to LEN bind CH when (FIXP (SETQ CH (BIN FORMSTREAM))) do (* ; "Filter out image objects") (\OUTCHAR OUTSTREAM CH)) (if LABEL then (TERPRI OUTSTREAM)) (* ; "Return T to show success") T)))
)

(AR.UPDATE.AR.INFO
(LAMBDA (FORMWINDOW OP AR.INFO USER.INFO) (* ; "Edited 22-Feb-88 15:44 by bvm") (* ;; "Write into the TDS file a description of what happened to this AR.") (AR.PROMPT.PRINT FORMWINDOW T "Updating TDS file...") (from 1 to AR.FILE.TRIES bind INFO.FILE CONDITION MSG *UPPER-CASE-FILE-NAMES* do (CL:MULTIPLE-VALUE-SETQ (INFO.FILE CONDITION) (IGNORE-ERRORS (OPENSTREAM AR.INFO.FILE.NAME (QUOTE BOTH) (QUOTE OLD/NEW) (QUOTE ((DON'T.CACHE T) (DON'TCACHE T)))))) (if INFO.FILE then (SETFILEPTR INFO.FILE -1) (CL:UNWIND-PROTECT (LET ((*PRINT-BASE* 10)) (LINELENGTH MAX.SMALLP INFO.FILE) (printout INFO.FILE "  --  " (LIST OP AR.INFO USER.INFO) T)) (CLOSEF INFO.FILE)) (AR.PROMPT.PRINT FORMWINDOW " done") (RETURN) else (if (NOT (STRING-EQUAL MSG (SETQ MSG (CL:FORMAT NIL "~A" CONDITION)))) then (AR.PROMPT.PRINT FORMWINDOW T MSG " --- please wait")) (DISMISS 5000)) finally (AR.PROMPT.PRINT FORMWINDOW T "Gave up trying to open info file--try again later") (ERROR!)))
)

(AR.PUT.FAILED
(LAMBDA (MSG FORMWINDOW) (* ; "Edited 18-Feb-88 11:12 by bvm") (RINGBELLS) (FLASHWINDOW FORMWINDOW 1) (AR.PROMPT.PRINT FORMWINDOW T MSG) (WINDOWPROP FORMWINDOW (QUOTE TITLE) (MKSTRING MSG)))
)
)
(DEFINEQ

(AR.CHECK.FIELDS
(LAMBDA (FORMWINDOW) (* ; "Edited 12-Feb-88 18:38 by bvm") (* ;; "Check that the AR is well-formed.  Return an error message if there is a problem.") (AR.MAP.BUTTONS FORMWINDOW (FUNCTION (LAMBDA (TOBJ OBJ CH#) (LET (FN CHECK.VALUE SEL FIELD.CH# FIELD.LEN) (if (AND (SETQ FN (IMAGEOBJPROP OBJ (QUOTE AR.CHECK.FN))) (NEQ FN (FUNCTION NILL))) then (if (IMAGEOBJPROP OBJ (QUOTE AR.PROTECTED.FLG)) then (SETQ FIELD.CH# (IPLUS (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.START)) CH#)) (SETQ FIELD.LEN (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.LEN))) else (SETQ SEL (MBUTTON.FIND.NEXT.FIELD TOBJ CH#)) (SETQ FIELD.CH# (fetch (SELECTION CH#) of SEL)) (SETQ FIELD.LEN (fetch (SELECTION DCH) of SEL))) (AND (SETQ CHECK.VALUE (CL:FUNCALL FN FORMWINDOW OBJ CH# FIELD.CH# FIELD.LEN)) (APPEND (LIST "Bad value for field [" (IMAGEOBJPROP OBJ (QUOTE MBTEXT)) "] --- ") CHECK.VALUE))))))))
)

(AR.CHECK.MENU
(LAMBDA (FORMWINDOW OBJ CH# FIELD.CH# FIELD.LEN) (* ; "Edited 12-Feb-88 11:58 by bvm") (LET ((CLIST (AR.READ.BYTES (TEXTSTREAM FORMWINDOW) FIELD.LEN (SUB1 FIELD.CH#))) VAL) (if (NULL CLIST) then (* ; "a null menu value is always correct") NIL elseif (MEMB (SETQ VAL (PACKC CLIST)) (IMAGEOBJPROP OBJ (QUOTE AR.MENU.LIST))) then NIL else (IMAGEOBJPROP OBJ (QUOTE AR.MENU) NIL) (LIST "bad menu value: " VAL " --- please reset"))))
)

(AR.CHECK.SHORTSTRING
(LAMBDA (FORMWINDOW OBJ CH# FIELD.CH# FIELD.LEN) (* edited%: "27-Jul-84 10:51") (if (ILEQ FIELD.LEN (IMAGEOBJPROP OBJ (QUOTE AR.MAX.LEN))) then NIL else (LIST "max length= " (IMAGEOBJPROP OBJ (QUOTE AR.MAX.LEN)) "; current length= " FIELD.LEN)))
)

(AR.CHECK.SUBMENU
(LAMBDA (FORMWINDOW OBJ CH# FIELD.CH# FIELD.LEN) (* ; "Edited 12-Feb-88 12:07 by bvm") (* ;; "Check that a submenu value is correct for the value given in the main menu.") (LET ((CLIST (AR.READ.BYTES (TEXTSTREAM FORMWINDOW) FIELD.LEN (SUB1 FIELD.CH#))) VAL) (IMAGEOBJPROP OBJ (QUOTE AR.ASSOCIATED.MENU.VAL) NIL) (* ; "??") (if (NULL CLIST) then (* ; "a null menu value is always correct") NIL elseif (MEMB (SETQ VAL (PACKC CLIST)) (LISTGET (IMAGEOBJPROP OBJ (QUOTE AR.SUBMENU.LIST)) (AR.GET.ASSOCIATED.MENU.VAL OBJ FORMWINDOW))) then NIL else (IMAGEOBJPROP OBJ (QUOTE AR.SUBMENUS) NIL) (IMAGEOBJPROP OBJ (QUOTE AR.ASSOCIATED.MENU.VAL) NIL) (LIST "bad menu value: " VAL " --- please reset"))))
)
)



(* ; "Special")

(DEFINEQ

(AR.FORM.GET/PUT.FILE
(LAMBDA (FORMWINDOW OPERATION) (* ; "Edited  5-Aug-88 11:09 by bvm") (AR.PROMPT.CLEAR FORMWINDOW) (LET* ((PWINDOW (GETPROMPTWINDOW FORMWINDOW)) (FILE (PROMPTFORWORD (if (EQ OPERATION (QUOTE Get)) then "Get File: " else "Put File: ") (WINDOWPROP FORMWINDOW (QUOTE AR.GET/PUT.FILE.NAME)) NIL PWINDOW NIL (QUOTE TTY)))) (TERPRI PWINDOW) (if FILE then (WINDOWPROP FORMWINDOW (QUOTE AR.GET/PUT.FILE.NAME) FILE) (if (EQ OPERATION (QUOTE Get)) then (AR.GET.AR FORMWINDOW FILE) elseif (SETQ FILE (AR.FORM.SAVE FORMWINDOW FILE)) then (WINDOWPROP FORMWINDOW (QUOTE TITLE) (CONCAT "Saved " FILE)) (TEDIT.STREAMCHANGEDP FORMWINDOW T)))))
)

(AR.GET.NEXT
(LAMBDA (FORMWINDOW) (* ; "Edited  5-Aug-88 11:21 by bvm") (* ;; "Gets the next (existing) AR in numeric order after CURR.NUM (the one now in the window).") (LET ((CURR.NUM (OR (WINDOWPROP FORMWINDOW (QUOTE AR.FORM.NUMBER)) (FIXP (AR.GET.NUMBER.FIELD FORMWINDOW))))) (if (NOT CURR.NUM) then (AR.PROMPT.PRINT FORMWINDOW "Can't GetNext when there isn't a current number") else (bind *UPPER-CASE-FILE-NAMES* AR.LIMIT do (* ;; "Keep going until we find a real AR.") (SETQ CURR.NUM (ADD1 CURR.NUM)) (COND ((INFILEP (AR.FILENAME CURR.NUM)) (* ; "ar exists. Get it.") (AR.MENU.FN.GET FORMWINDOW CURR.NUM) (RETURN)) ((>= CURR.NUM (OR AR.LIMIT (SETQ AR.LIMIT (AR.GET.SUBMIT.NUM FORMWINDOW T)) (RETURN))) (* ; "next AR number is equal to the number to be assigned to the next AR submitted") (AR.PROMPT.PRINT FORMWINDOW T "Next " AR.IDENTIFICATION.STRING " hasn't been submitted yet.") (RETURN)) (T (AR.PROMPT.PRINT FORMWINDOW T AR.IDENTIFICATION.STRING " #" CURR.NUM " doesn't exist, checking next ar.")))))))
)

(AR.FORM.FILL.IN.DEFAULTS
(LAMBDA (FORMWINDOW) (* ; "Edited  4-Aug-88 15:36 by bvm") (LET ((FORMSTREAM (TEXTSTREAM FORMWINDOW)) ALREADY.FILLED DEFAULTS) (AR.MAP.BUTTONS FORMSTREAM (FUNCTION (LAMBDA (TOBJ OBJ CH#) (LET ((NEWVALUE (IMAGEOBJPROP OBJ (QUOTE FILLINVALUE)))) (* ; "Yes, this button has a %"Fill In Defaults%" prop") (if NEWVALUE then (push DEFAULTS (LIST (IMAGEOBJPROP OBJ (QUOTE MBTEXT)) (if (LISTP NEWVALUE) then (EVAL NEWVALUE) else NEWVALUE))) (if (> (if (IMAGEOBJPROP OBJ (QUOTE AR.PROTECTED.FLG)) then (IMAGEOBJPROP OBJ (QUOTE AR.FIELD.LEN)) else (fetch (SELECTION DCH) of (OR (MBUTTON.FIND.NEXT.FIELD TOBJ CH#) (SHOULDNT "Can't find field for button")))) 0) then (* ; "Field already has a value") (push ALREADY.FILLED (IMAGEOBJPROP OBJ (QUOTE MBTEXT))))) (* ; "Return NIL so that the iteration continues") NIL)))) (if (AND ALREADY.FILLED (NOT (MOUSECONFIRM (LET ((*PRINT-CASE* :UPCASE)) (CL:FORMAT NIL "The ~{~A ~}field~:[ is~;s are~] already non-empty" ALREADY.FILLED (CDR ALREADY.FILLED))) "Click LEFT to overwrite anyway" (GETPROMPTWINDOW FORMWINDOW)))) then (ERROR!)) (AR.REPLACE.FILL.INS FORMWINDOW DEFAULTS) (AR.PROMPT.PRINT FORMWINDOW " done")))
)

(AR.CURRENT.LISP.VERSION
(LAMBDA NIL (* ; "Edited 16-Feb-88 13:15 by bvm") (CONCAT (L-CASE MAKESYSNAME T) " " (SUBSTRING MAKESYSDATE 1 (if (STRING-EQUAL MAKESYSNAME "LISPCORE") then (* ; "Give the whole gory date") NIL else (* ; "Assume only one real release per day (tee hee), so skip the time") -10))))
)
)



(* ; "Misc")

(DEFINEQ

(AR.PROMPT
(LAMBDA (WORDS FORMWINDOW) (* ; "Edited 10-Feb-88 14:08 by bvm") (PROG ((*PRINT-BASE* 10) (PWINDOW (GETPROMPTWINDOW FORMWINDOW 2))) (CLEARW PWINDOW) (if (LISTP WORDS) then (for X in WORDS do (PRIN1 X PWINDOW)) else (PRIN1 WORDS PWINDOW))))
)

(AR.PROMPT.PRINT
(LAMBDA ARGS (* ; "Edited 20-Jul-88 18:24 by bvm") (* ;; "Real arglist is (formwindow &rest strings).  Prints each of strings to FORMWINDOW's prompt window.  T means new line.") (LET ((*PRINT-BASE* 10) (PWINDOW (GETPROMPTWINDOW (ARG ARGS 1) 2)) STR) (for I from 2 to ARGS do (SELECTQ (SETQ STR (ARG ARGS I)) (T (FRESHLINE PWINDOW)) (:CLEAR (CLEARW PWINDOW)) (PRIN1 STR PWINDOW)))))
)

(AR.PROMPT.CLEAR
(LAMBDA (FORMWINDOW) (* ; "Edited 17-Feb-88 11:13 by bvm") (CLEARW (GETPROMPTWINDOW FORMWINDOW 2))))

(AR.GET.FILENAME
(LAMBDA (NUM PUTFLG) (* jds " 7-Nov-86 10:48") (* ;; "Convert from an AR number to the corresponding file name") (* ;;; "PROG (FILE) (CLRPROMPT) (SETQ FILE (PROMPTFORWORD (CONCAT 'What file should I use for AR# ' NUM '? ') NIL NIL PROMPTWINDOW)) (if FILE then (RETURN (MKATOM FILE))) (if PUTFLG then (FRESHLINE PROMPTWINDOW) (printout PROMPTWINDOW 'do you really want to PUT to the lispar database?') (if (NULL (MOUSECONFIRM)) then (RETURN NIL))) (RETURN (AR.FILENAME NUM))") (COND ((FIXP NUM) (AR.FILENAME NUM)) (T NIL)))
)

(AR.READ.NUMBER
(LAMBDA (RETFLG) (* ; "Edited  4-Aug-88 12:37 by bvm") (RESETLST (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (PROMPTPRINT "Type or select digits of desired AR.") (RESETSAVE NIL (QUOTE (CLRPROMPT))) (OR (RNUMBER (CONCAT AR.IDENTIFICATION.STRING " number") NIL NIL NIL T NIL T T) (AND (NOT RETFLG) (ERROR!)))))
)

(AR.FILENAME
(LAMBDA (ARN) (* ; "Edited 12-Feb-88 16:19 by bvm") (CONCAT AR.DIRECTORY (SUBSTRING (+ 100000 ARN) -5 -1) ".AR"))
)

(AR.READ.BYTES
(LAMBDA (STREAM NBYTES START) (* ; "Edited 12-Feb-88 12:46 by bvm") (* ;; "Collect a list of NBYTES bytes by reading from STREAM starting at START or current position") (if START then (SETFILEPTR STREAM START)) (to NBYTES collect (BIN STREAM)))
)

(AR.USERNAME
(LAMBDA NIL (* ; "Edited  4-Aug-88 15:08 by bvm") (if (GETD (QUOTE FULLUSERNAME)) then (FULLUSERNAME) else (USERNAME NIL NIL T)))
)
)



(* ; "These have special knowledge of TEdit I wish I didn't really need")

(DEFINEQ

(TEDIT.FAST.RAW.INCLUDE
  [LAMBDA (TEXTSTREAM INSTREAM START END INSERTCH#)      (* ; "Edited 15-Jun-90 10:42 by jds")

    (* ;; "takes a text stream and an OPEN stream to include at character INSERTCH#.  Note: Start and End are inclusive ptrs, unlike in copybytes and friends.  No interpretation (alternate file type e.g. Bravo) takes place.  INSTREAM is not copied, so you'd better not be changing it.")

    (LET* [(TEXTOBJ (TEXTOBJ TEXTSTREAM))
           (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
           (INSPC# (OR (\CHTOPCNO INSERTCH# PCTB)
                       (INDEX (fetch CHNUM of (\LASTNODE PCTB))
                              PCTB)))
           (INSPC (fetch PCE of (FINDNODE-INDEX PCTB INSPC#)))
           (LEN (- (OR END (GETEOFPTR INSTREAM))
                   (OR START (SETQ START 0]                  (* ; 
                                                      "INSPC is the piece to make the insertion in")
          (COND
             ([AND (NEQ INSPC 'LASTPIECE)
                   (> INSERTCH# (fetch CHNUM of (FINDNODE-INDEX PCTB INSPC#]
                                                             (* ; "Must split the piece.")
              (SETQ INSPC (\SPLITPIECE INSPC INSERTCH# TEXTOBJ INSPC#))
              (add INSPC# 1)))
          (\TEDIT.INSERT.PIECES TEXTOBJ INSERTCH#
                 (create PIECE
                        PFILE _ INSTREAM
                        PFPOS _ START
                        PLEN _ LEN
                        PREVPIECE _ NIL
                        NEXTPIECE _ NIL
                        PLOOKS _ (fetch (TEXTOBJ DEFAULTCHARLOOKS) of TEXTOBJ)
                        PPARALAST _ NIL
                        PPARALOOKS _ (fetch (TEXTOBJ FMTSPEC) of TEXTOBJ))
                 LEN INSPC INSPC#)
          (add (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)
                 LEN])

(AR.PIECE.CHANGED
  [LAMBDA (TEXTOBJ TEXTSTREAM CH# REFSTREAM START LEN)   (* ; "Edited 15-Jun-90 10:42 by jds")

    (* ;; "Compares TEXTOBJ/TEXTSTREAM at position CH# with the contents of REFSTREAM from filepointer START for the next LEN bytes.  If they're different, returns T.")

    (* ;; "Do this by comparing pieces.  This is fast in the average case (the piece is unchanged), and takes into account the fact that the textstream may be backed by REFSTREAM, so file pointers would step on each other.")

    (LET* ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ))
           (PIECE# (\CHTOPCNO CH# PCTB))
           PIECE)
          (if (NULL PIECE#)
              then                                       (* ; "Shouldn't happen")
                    T
            else (SETQ PIECE (fetch PCE of (FINDNODE-INDEX PCTB PIECE#)))
                  (do (if (ATOM PIECE)
                              then                       (* ; "Shouldn't happen")
                                    (RETURN NIL))
                         (if [NOT (if (EQ (fetch (PIECE PFILE) of PIECE)
                                                  REFSTREAM)
                                          then           (* ; 
               "Same as reference stream--they're same if starts match, assume different otherwise")
                                                (= (fetch (PIECE PFPOS) of PIECE)
                                                   START)
                                        else             (* ; 
                                                          "Somewhere else, so compare byte by byte")
                                              (SETFILEPTR TEXTSTREAM (SUB1 CH#))
                                              (SETFILEPTR REFSTREAM START)
                                              (to (fetch (PIECE PLEN) of PIECE)
                                                 always (EQ (BIN TEXTSTREAM)
                                                                (BIN REFSTREAM]
                             then (RETURN T))
                         (if (> (SETQ LEN (- LEN (fetch (PIECE PLEN) of PIECE)))
                                    0)
                             then (add START (fetch (PIECE PLEN) of PIECE))
                                   (add CH# (fetch (PIECE PLEN) of PIECE))
                                   (SETQ PIECE (fetch (PIECE NEXTPIECE) of PIECE))
                           else                          (* ; 
                                                   "That's all the way to the end, so we succeeded")
                                 (RETURN NIL])
)



(* ; "Patch for Lyric")

(DEFINEQ

(AR.UNSELECT.ITEM
(LAMBDA (BROWSER ITEM) (* ; "Edited 18-Feb-88 10:55 by bvm") (\CALLME (QUOTE TB.UNSELECT.ITEM)) (* ;; "Copy of the definition of TB.UNSELECT.ITEM for use in Lyric (where there was no such beast)") (if (ffetch (TABLEITEM TISELECTED) of (\DTEST ITEM (QUOTE TABLEITEM))) then (LET ((N (ffetch (TABLEITEM TI#) of ITEM))) (TB.DESELECTRANGE (\DTEST BROWSER (QUOTE TABLEBROWSER)) N N) (TB.SHOW.SELECTION BROWSER N (QUOTE ERASE)))))
)
)



(* ; "Hardcopying AR's")

(DEFINEQ

(AR.DISPLAY
(LAMBDA (AR# WINDOW PROMPTW) (* ; "Edited  4-Aug-88 12:40 by bvm") (* ;; "Displays AR# as a readonly textstream.  Uses WINDOW if given, otherwise prompts for one.  PROMPTW is optional window for error messages.") (LET ((TITLE (CONCAT AR.IDENTIFICATION.STRING " " AR#)) TS) (if WINDOW then (CLEARW WINDOW) (WINDOWPROP WINDOW (QUOTE TITLE) TITLE) else (SETQ WINDOW (CREATEW NIL TITLE)) (WINDOWPROP WINDOW (QUOTE ICONFN) (FUNCTION TEXTICON))) (if (SETQ TS (AR.DISPLAY.TEXTSTREAM AR# (WINDOWPROP WINDOW (QUOTE WIDTH)) NIL PROMPTW)) then (OPENTEXTSTREAM TS WINDOW NIL NIL (QUOTE (READONLY T SEL DON'T))))))
)

(AR.HARDCOPY
(LAMBDA (NUMBERS PROMPTW) (* ; "Edited  4-Aug-88 12:43 by bvm") (* ;; "Hardcopy the ARs in the list NUMBERS.  PROMPTW is window for progress output and error messages, defaults to T.") (if (AND NUMBERS (NLISTP NUMBERS)) then (SETQ NUMBERS (LIST NUMBERS))) (if (NULL PROMPTW) then (SETQ PROMPTW (GETSTREAM T (QUOTE OUTPUT)))) (for TAIL on NUMBERS bind TEXTSTREAM VALUE (TITLE _ (COND ((CDR NUMBERS) (CONCAT "Selected " AR.IDENTIFICATION.STRING "s")) (T (CONCAT AR.IDENTIFICATION.STRING "# " (CAR NUMBERS))))) (N _ 0) (PARTNO _ 0) (LASTPAGENO _ 0) NPAGES do (if (SETQ VALUE (AR.DISPLAY.TEXTSTREAM (CAR TAIL) AR.HARDCOPY.WIDTH (if TEXTSTREAM elseif (CDR NUMBERS) then (* ; "Make our own textstream with a pagelayout so we can print running headers") (* ; "Note that PY is lower than header Y because of TEdit bug in placement") (OPENTEXTSTREAM "" NIL NIL NIL (BQUOTE (FONT (\, ARFONT) PARALOOKS (PARALEADING 1) PAGEFORMAT (\, (TEDIT.SINGLE.PAGEFORMAT T -36 (- -36 AR.HARDCOPY.PAGENO.KLUDGE.OFFSET) (BQUOTE (FONT (\, ARHEADERFONT))) (QUOTE RIGHT) 72 36 72 72 NIL NIL NIL (BQUOTE ((HEADING (\, (- -36 (STRINGWIDTH (CONCAT AR.IDENTIFICATION.STRING " 99999999") ARHEADERFONT))) -36))) NIL (BQUOTE (STARTINGPAGE# (\, (ADD1 LASTPAGENO)))))) TEDIT.TENTATIVE NIL)))) PROMPTW)) then (SETQ TEXTSTREAM VALUE) (PRIN1 "." PROMPTW) (add N 1) (if (AND (CDR TAIL) (> (GETEOFPTR TEXTSTREAM) AR.HARDCOPY.MAXLENGTH)) then (* ; "That's enough for one pass, let's send it off") (FRESHLINE PROMPTW) (PRINTOUT PROMPTW "Formatting part " (add PARTNO 1)) (SETQ NPAGES (TEDIT.HARDCOPY TEXTSTREAM NIL NIL (CONCAT TITLE " [Part " PARTNO "]"))) (if (FIXP NPAGES) then (* ; "Doesn't work in Lyric") (add LASTPAGENO NPAGES)) (PRINTOUT PROMPTW "...done" T) (SETQ TEXTSTREAM NIL))) finally (RETURN (if TEXTSTREAM then (* ; "Could be empty if none of the numbers were good.  Can have the Hardcopy done in its own process, since we do't need to wait for the storage to be free.") (if (NEQ PARTNO 0) then (SETQ TITLE (CONCAT TITLE " [Part " (add PARTNO 1) "]")) else (SETQ PARTNO NIL)) (ADD.PROCESS (BQUOTE ((\, (FUNCTION TEDIT.HARDCOPY)) (QUOTE (\, TEXTSTREAM)) NIL NIL (QUOTE (\, TITLE))))) (CONCAT (if (NULL (CDR NUMBERS)) then TITLE else (CL:FORMAT NIL "~D ~As~@[ in ~D parts~]" N AR.IDENTIFICATION.STRING PARTNO)) " queued for printing")))))
)

(AR.DISPLAY.TEXTSTREAM
(LAMBDA (AR# WIDTH TEXTSTREAM PROMPTW) (* ; "Edited  4-Aug-88 12:44 by bvm") (* ;; "Create a textstream containing the contents of AR# layed out as in an AR edit window, but vanilla readonly text.  WIDTH is the width I would like tabs layed out.  If an error occurs, prints the condition to PROMPTW and returns NIL.  If TEXTSTREAM is supplied, new AR is appended to it, and a header line is placed before it (this is for multiple hardcopy).") (PROG ((SCRATCH (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (BOLD (LIST (QUOTE FONT) ARBOLDFONT)) (NTABS 0) CH# FIRSTCH# TABSTOPS TAB.CH# SPEC LEN MAP LASTFIELD CONDITION) (CL:MULTIPLE-VALUE-SETQ (MAP CONDITION) (AR.FETCH.AND.PARSE.AR AR# SCRATCH)) (if CONDITION then (* ; "Failed to load ar") (PRINTOUT PROMPTW T (CL:TYPECASE CONDITION (XCL:FILE-NOT-FOUND (CONCAT "Can't find " AR.IDENTIFICATION.STRING " " AR#)) (T (CL:FORMAT NIL "Failed to load ~A ~A because: ~A" AR.IDENTIFICATION.STRING AR# CONDITION)))) (RETURN NIL)) (if TEXTSTREAM then (* ; "Appending to existing stream") (SETQ CH# (SETQ FIRSTCH# (ADD1 (GETEOFPTR TEXTSTREAM)))) else (SETQ TEXTSTREAM (OPENTEXTSTREAM "" NIL NIL NIL (BQUOTE (FONT (\, ARFONT) PARALOOKS (PARALEADING 1) TEDIT.TENTATIVE NIL)))) (SETQ CH# 1)) (for FIELD in (OR AR.DISPLAY.FORMAT AR.FORM.FORMAT) do (BLOCK) (if (EQ FIELD (QUOTE TAB)) then (* ; "Separates fields all on one line") (SETQ TAB.CH# CH#) (add NTABS 1) (if (EQ LASTFIELD (QUOTE TAB)) then (* ; "two tabs in a row, I'll punt the optimization") (TEDIT.INSERT TEXTSTREAM "	") (add CH# 1)) elseif (EQ FIELD (QUOTE CR)) then (* ; "Go to a new line.  Come up with tabs to divide the space evenly among the fields") (if (> NTABS 0) then (push TABSTOPS NTABS TAB.CH#) (SETQ NTABS 0)) (TEDIT.INSERT TEXTSTREAM "
" CH#) (add CH# 1) elseif (NOT (LITATOM FIELD)) then (* ; "Random string to print") (if (EQ LASTFIELD (QUOTE TAB)) then (TEDIT.INSERT TEXTSTREAM "	") (add CH# 1)) (TEDIT.INSERT TEXTSTREAM FIELD CH#) (add CH# (NCHARS FIELD)) else (* ; "It's a field") (TEDIT.INSERT TEXTSTREAM (SETQ SPEC (if (EQ LASTFIELD (QUOTE TAB)) then (* ; "Pack in a saved up tab to reduce the total string usage") (CONCAT "	" FIELD "  ") else (CONCAT FIELD "  "))) CH# BOLD) (add CH# (NCHARS SPEC)) (SETQ SPEC (ASSOC FIELD MAP)) (if (AND SPEC (> (SETQ LEN (CADDR SPEC)) 0)) then (* ; "Insert body of field") (TEDIT.FAST.RAW.INCLUDE TEXTSTREAM SCRATCH (SETQ SPEC (CADR SPEC)) (+ SPEC LEN) CH#) (add CH# LEN))) (SETQ LASTFIELD FIELD)) (while TABSTOPS bind CACHED.TABS TB do (* ; "Process each <#tabs chpos> pair and set a tab stop there.") (SETQ NTABS (pop TABSTOPS)) (TEDIT.PARALOOKS TEXTSTREAM (if (CDR (ASSOC NTABS CACHED.TABS)) else (* ; "Cache tab settings for this number of tabs") (push CACHED.TABS (CONS NTABS (SETQ TB (BQUOTE (TABS (NIL (\,@ (for I from 1 to NTABS bind (TABWIDTH _ (IQUOTIENT WIDTH (ADD1 NTABS))) collect (CONS (ITIMES I TABWIDTH) (QUOTE LEFT)))))))))) TB) (pop TABSTOPS) 1)) (if FIRSTCH# then (* ; "Insert a header paragraph in front of AR text") (LET ((HEAD (CONCAT AR.IDENTIFICATION.STRING " " AR# "
"))) (TEDIT.INSERT TEXTSTREAM HEAD FIRSTCH# (BQUOTE (FONT (\, ARHEADERFONT)))) (TEDIT.PARALOOKS TEXTSTREAM (QUOTE (TYPE PAGEHEADING SUBTYPE HEADING LINELEADING 0 PARALEADING 0)) FIRSTCH# 1) (if (> FIRSTCH# 1) then (* ; "Also need page break") (TEDIT.PARALOOKS TEXTSTREAM (QUOTE (NEWPAGEBEFORE T)) (+ FIRSTCH# (NCHARS HEAD)) 1))) else (* ; "Get rid of the selection") (TEDIT.SETSEL TEXTSTREAM CH# 0 (QUOTE RIGHT))) (RETURN TEXTSTREAM)))
)
)

(RPAQ? AR.HARDCOPY.WIDTH 504)

(RPAQ? AR.HARDCOPY.MAXLENGTH 40000)

(RPAQ? AR.DISPLAY.FORMAT NIL)



(* ; "These VARS are AR-system change these to work on different AR databases")


(RPAQQ AR.FORM.FORMAT
       (Number%: TAB Date%: CR Submitter%: TAB Source%: CR CR Subject%: CR CR |Assigned To:| TAB 
              Attn%: CR CR Status%: TAB In/By%: CR |Problem Type:| TAB Impact%: CR Difficulty%: TAB 
              Frequency%: CR TAB Priority%: CR CR System%: TAB Subsystem%: CR CR Machine%: TAB Disk%:
              CR |Lisp Version:| TAB |Source Files:| CR |Microcode Version:| TAB |Memory Size:| CR 
              |File Server:| TAB |Server Software Version:| CR CR Disposition%: CR CR |Release Note:|
              CR CR Description%: CR CR Workaround%: CR |Test Case:| CR CR Edit-By%: TAB Edit-Date%:
              CR))

(RPAQQ AR.FORM.SPECS
       ((Number%: FIELDTYPE PROTECTEDSTRING)
        (Date%: FIELDTYPE PROTECTEDSTRING)
        (Submitter%: FIELDTYPE STRING INITIALVALUE (AR.USERNAME))
        (Source%: FIELDTYPE STRING INITIALVALUE (AR.USERNAME))
        (Subject%: FIELDTYPE STRING)
        (|Assigned To:| FIELDTYPE STRING)
        (Attn%: FIELDTYPE STRING)
        (Status%: FIELDTYPE MENU MENULIST (New Open Open/Unreleased Fixed Closed Declined Superseded
                                               Obsolete Incomplete Internal Wish)
               INITIALVALUE New)
        (In/By%: FIELDTYPE STRING)
        (|Problem Type:| FIELDTYPE MENU MENULIST (Bug |Design - Impl| Feature |Design - UI| 
                                                      Documentation Performance))
        (Impact%: FIELDTYPE MENU MENULIST (Fatal Serious Moderate Annoying Minor))
        (Difficulty%: FIELDTYPE MENU MENULIST (Easy Moderate Hard Very% Hard Impossible))
        (Frequency%: FIELDTYPE MENU MENULIST (Everytime Intermittent Once))
        (Priority%: FIELDTYPE MENU MENULIST (Absolutely Hopefully Perhaps Unlikely))
        (System%: FIELDTYPE MENU ASSOCSUBMENU Subsystem%: MENULIST
               (Communications |Windows and Graphics| Operating% System Language% Support 
                      Programming% Environment Text Common% Lisp CLOS Port Maiko LOOPS PCE PROLOG 
                      4045 Rooms Library BusMaster NoteCards Documentation Other% Software))
        (Subsystem%: FIELDTYPE SUBMENU ASSOCMENU System%: SUBMENULIST
               (Communications (NS% Protocols NS% Filing NS% Printing PUP% Protocols PUP% FTP 
                                      Grapevine Leaf RS232 VAX% Server DEI EVMS/RPC Lisp% Servers 
                                      Clearinghouse TCP/IP Centronics TTYPort Chat Chat% Interface 
                                      |Pup Chat Driver| |NS Chat Driver| |RS232 Chat Driver| 
                                      |TTYPort Chat Driver| |Chat DM2500 Emulator| 
                                      |Chat VT100 Emulator| NSMaintain Other)
                      |Windows and Graphics|
                      (Window% System Library Fonts Printing Color Bitmaps Demos Menus Other)
                      Operating% System
                      (Virtual% Memory |Generic File Operations| DLion% Disk Daybreak% Disk 
                             DLion% Floppy Daybreak% Floppy Dolphin/Dorado% Disk Processes Streams 
                             Keyboard Mouse Other)
                      Language% Support
                      (Arithmetic |Compiler, Code Format| For/If Microcode Storage% Formats/Mgt 
                             Garbage% Collection |Read and Print| |Stack and Interpreter| 
                             |Bootstrapping and Teleraid| Diagnostics Other)
                      Programming% Environment
                      (Break% Package Code% Editor DWIM Inspector File% Package History Masterscope 
                             PSW Record% Package Performance% Tools Edit% Interface Exec 
                             Presentations Stepper Other)
                      Text
                      (TEdit TTYIN Lafite AR% Database Other)
                      Common% Lisp
                      (Type% System Declarations Macros Control% Structure Evaluator Symbols/Packages
                             Arithmetic Characters/Strings Sequences Lists Arrays Structures 
                             Hash% Tables |Streams and I/O| |File System Interface| Error% System 
                             Compiler Tamarin% Support Microcoded% Operations Common% Loops Other)
                      CLOS
                      (Language Browsers Methods Classes Meta% Classes Other)
                      Port
                      (Other)
                      Maiko
                      (Bytecode% Emulation Native% Code I/O% System Host% Integration 
                             |Host User Interface| |Foreign Fn Interface| Installation% Procedure 
                             Documentation Other)
                      LOOPS
                      (Active% Values Composite% Objects Objects Browsers User% Interface 
                             Virtual% Copy Other)
                      PCE
                      (Monochrome% Display Color% Display Keyboard |Emulated Rigid Disk| Floppy% Disk
                             Printer% Port User% Interface Programmatic% Interface 
                             |File System Interface| Memory Ethernet Configuration% Tools Other)
                      PROLOG
                      (Arithmetic Dinfo Microcode Editor% Interface Compiler Interpreter I/O 
                             Debugging Prolog-Lisp% Interface Other)
                      4045
                      (XLPStream Remoteserver HQStream PSO Other)
                      Rooms
                      (Window% Types Overview Suites Buttons Documentation Other)
                      Library
                      (Cash-File Centronics CharCodeTables Copyfiles DEdit DatabaseFns EditBitmap 
                             |FX-80 Printer Support| Filebrowser Font% Samples GCHax GraphZoom 
                             Grapher Hash Hash-File |Image Object Interface| Kermit 
                             Masterscope% Browser MatMult |Press Printer Support| ReadNumber SameDir
                             Sketch SysEdit/EXPORTS.ALL Tablebrowser TExec TextModules 
                             Virtual% Keyboards Where-Is Other)
                      BusMaster
                      (Speech Color Other)
                      NoteCards
                      (User% Interface Programmer's% Interface System% Interface Notefiles Links 
                             Documentation Text% Cards File% Boxes Sketch% Cards Graph% Cards 
                             Browser% Cards Search% Cards |Link Index Cards| Document% Cards 
                             Other% Cards Library)
                      Documentation
                      (Tools |1108 Users Guide| |1186 Users Guide| Primer 
                             |Product Descr/Tech Summary| |Hardware Installation Guide| 
                             Programmers% Introduction |Interlisp Reference Manual| 
                             |Library Package Manual| |Internal System Documentation| Other)
                      Other% Software
                      (Installation% Utility Release% Procedure Other)))
        (Machine%: FIELDTYPE MENU ASSOCSUBMENU Disk%: MENULIST (1100 1108 1132 1186)
               FILLINVALUE
               (SELECTQ (MACHINETYPE)
                      (DANDELION 1108)
                      (DOLPHIN 1100)
                      (DORADO 1132)
                      (DOVE 1186)
                      AR.NULL.BUTTON.VALUE))
        (Disk%: FIELDTYPE SUBMENU ASSOCMENU Machine%: SUBMENULIST
               (1100 NIL 1108 (|SA1000 (10MB)| |SA4000 (29MB)| |Q2040 (43MB)| |Q2080 (80MB)| 
                                     |T80 (80MB)| |T300 (300MB)| Other)
                     1132
                     (|T80 (80MB)| Century315 Other)
                     1186
                     (|ST212 (10MB)| |TM703 (20MB)| |TM702 (20MB)| |ST4026 (20MB)| |Q530 (20MB)| 
                            |Q540 (40MB)| |Micropolis 1303 (40MB)| |Micropolis 1325 (80MB)|)))
        (|Lisp Version:| FIELDTYPE STRING FN AR.BUTTONFN.OFFER.DEFAULT FILLINVALUE (
                                                                              AR.CURRENT.LISP.VERSION
                                                                                    ))
        (|Source Files:| FIELDTYPE STRING)
        (|Microcode Version:| FIELDTYPE STRING FILLINVALUE (MICROCODEVERSION))
        (|Memory Size:| FIELDTYPE STRING FILLINVALUE (REALMEMORYSIZE))
        (|File Server:| FIELDTYPE MENU MENULIST (8037 IFS NS |VAX/VMS - 3Mb| |VAX/VMS - 10Mb| 
                                                      VAX/UNIX Micro% VAX/VMS Other))
        (|Server Software Version:| FIELDTYPE STRING)
        (Disposition%: FIELDTYPE PROTECTEDSTRING)
        (|Release Note:| FIELDTYPE STRING)
        (Description%: FIELDTYPE STRING)
        (Workaround%: FIELDTYPE STRING)
        (|Test Case:| FIELDTYPE STRING)
        (Edit-By%: FIELDTYPE PROTECTEDSTRING)
        (Edit-Date%: FIELDTYPE PROTECTEDSTRING)))

(RPAQQ AR.INTERESTING.SUBMIT.FIELDS (|Release Note:| Workaround%: |Test Case:|))

(RPAQ AR.DIRECTORY "{AR:MV:Envos}<LispARs>")

(RPAQ AR.INFO.FILE.NAME "{AR:MV:Envos}<LispARs>LispARs.tds")

(RPAQ AR.SUBMIT.NUM.FILE.NAME "{AR:MV:Envos}<LispARs>LispARs.num")

(RPAQ AR.IDENTIFICATION.STRING "AR")

(RPAQ? ARBUTTONFONT (FONTCREATE 'HELVETICA 12 'BOLD))

(RPAQ? ARFONT (FONTCREATE 'TIMESROMAN 10))

(RPAQ? ARBOLDFONT (FONTCREATE 'HELVETICA 10 'BOLD))

(RPAQ? ARHEADERFONT (FONTCREATE 'HELVETICA 8))

(RPAQ? AR.ICONFONT (FONTCREATE 'GACHA 8))

(RPAQ? AR.FILE.TRIES 10)

(RPAQ? AR.NO.MESSAGE.FLG NIL)

(RPAQ AR.NULL.BUTTON.VALUE (PACKC))

(RPAQQ AR.FORM.MENU.TITLEMENU.ITEMS
       ((Clear '(AR.MENU.FN.CLEAR NIL)
               "Clears all the fields of the AR")
        (New '(AR.MENU.FN.CLEAR T)
             "Same as creating a new form: sets all fields to default initial values")
        (Get 'Get "Retrieves the AR whose number is given in the %"Number:%" field")
        (GetNext 'AR.GET.NEXT "Gets the next existing AR after this one")
        (Put 'AR.MENU.FN.PUT "Saves an edited AR, or submits a new AR")
        ("Put & GetNext" 'AR.MENU.FN.PUT&GETNEXT 
               "Stores the current AR, and Gets the next existing AR")
        ("Put & Get" 'AR.MENU.FN.PUT&GET "Stores the current AR, and Gets another")
        ("Get From File" '(AR.FORM.GET/PUT.FILE Get)
               "Retrieves AR from named file")
        ("Put To File" '(AR.FORM.GET/PUT.FILE Put)
               "Stores AR into named file")
        ("Fill In Defaults" 'AR.FORM.FILL.IN.DEFAULTS 
         "Fills in default values for Microcode Version, Machine Type, Lisp Version, and Memory Size"
               )))

(RPAQQ AR.FORM.MENU.TITLEMENU NIL)

(RPAQQ AR.FORM.ICONSPEC (#*(60 60)OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@CO@@@@@@C@L@@@@@GOH@@@@@C@L@@@@@NAL@@@@@C@L@@CH@L@L@@@@@C@L@@OL@L@L@CN@@C@L@ALL@L@L@CO@@C@L@GHN@L@L@GCH@C@L@N@F@L@L@FAL@C@LGH@F@NAL@F@G@C@LG@@BCOOO@L@CHC@LD@@CGOOOIL@ALC@L@@@CO@@CMH@@NC@L@@@CL@@@O@@@FC@L@@@CH@@@G@@@@C@L@@@O@@@@CH@@@C@L@@@LCOCO@L@@@C@L@@@LGOCOHN@@@C@L@GAHNCCALF@@@C@L@GMHLCC@LF@@@C@L@MOHLCC@LGOL@C@LAHC@LCC@LCON@C@LAHC@LCC@LC@N@C@LC@C@OOCOLC@C@C@LC@C@OOCOLC@C@C@LF@C@LCCG@C@AHC@LF@C@LCCCHC@AHC@LF@C@LCCALC@@LC@LF@CHLCC@LF@@NC@L@@AHLCC@LF@@FC@L@@AHLCC@LF@@FC@L@@@LLCC@LL@@@C@L@AOLLCC@LON@@C@L@AOLLCC@LON@@C@L@AHN@CC@ALF@@C@L@AHF@CC@AHC@@C@L@CHF@CC@AHC@@C@L@C@C@CC@C@AH@C@L@C@CHCC@G@AH@C@L@C@AHCC@F@AH@C@L@C@@N@@AN@AL@C@L@F@@G@@CL@@L@C@L@F@@CNCOH@@N@C@L@N@@AOON@@@F@C@L@L@@@CN@@@@C@C@LAH@@@@@@@@@CHC@LAH@@@@@@@@@ALC@LC@@@@@@@@@@ALC@LF@@@@@@@@@@@NC@LF@@@@@@@@@@@FC@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@
                             NIL
                             (15 2 30 10)))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS AR.FORM.ICONSPEC AR.NULL.BUTTON.VALUE AR.HARDCOPY.PAGENO.KLUDGE.OFFSET AR.MENU.READTABLE
       TEDIT.READTABLE AR.FORM.MENU.TITLEMENU)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)


                                                             (* ; 
                                                       "Need TEDITDECLS for TEDIT.FAST.RAW.INCLUDE")

(OR (GET 'TEDITDECLS 'FILE)
    (LOAD 'TEDITDECLS))
)
(DECLARE%: EVAL@COMPILE DOCOPY 

(CL:PROCLAIM '(CL:SPECIAL AR.INFO.FILE.NAME AR.SUBMIT.NUM.FILE.NAME AR.DIRECTORY AR.NO.MESSAGE.FLG 
                     ARBUTTONFONT ARFONT ARBOLDFONT ARHEADERFONT AR.ICONFONT AR.FILE.TRIES 
                     AR.HARDCOPY.MAXLENGTH AR.FORM.FORMAT AR.FORM.SPECS AR.HARDCOPY.WIDTH 
                     AR.DISPLAY.FORMAT AR.IDENTIFICATION.STRING AR.FORM.MENU.TITLEMENU.ITEMS 
                     AR.INTERESTING.SUBMIT.FIELDS))
)

(FILESLOAD (SYSLOAD)
       ARQUERY TABLEBROWSER TEDIT READNUMBER)

(RPAQ AR.HARDCOPY.PAGENO.KLUDGE.OFFSET (COND ((> (IDATE TEDITSYSTEMDATE)
                                                     (IDATE "23-feb-88 0000"))
                                                             (* ; "Bug was fixed")
                                                  0)
                                                 (T 2)))
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(COND
   ((EQ MAKESYSNAME :LYRIC)
    (FILESLOAD (SYSLOAD)
           MVALUESPATCH)
    (MOVD? 'AR.UNSELECT.ITEM 'TB.UNSELECT.ITEM NIL T)))

(PUTD 'AR.UNSELECT.ITEM NIL)


                                                             (* ; 
                                     "Install background menu command.  Smash any previous AREdit.")

[/RPLACD [OR (CL:ASSOC "AR Edit" BackgroundMenuCommands :TEST 'STRING-EQUAL)
             (CAR (RPAQ BackgroundMenuCommands (CONS (LIST "AR Edit")
                                                         BackgroundMenuCommands))]
       '('(AR.FORM)
         "Create a new AR editor for the Lisp AR database"
         (SUBITEMS ("New AR form" '(AR.FORM)
                          "Creates a new AR editor, cleared ready to submit a new AR.")
                ("Load AR" '(AR.FORM (AR.READ.NUMBER))
                       "Creates a new AR editor and loads a specified AR into it")
                ("Display AR" '(AR.DISPLAY (AR.READ.NUMBER))
                       "Displays a specified AR in a read-only window")
                ("AR Query Form" '(AR.QFORM.CREATE)
                       "Creates an AR Query Form"]

(RPAQ BackgroundMenu )
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA AR.PROMPT.PRINT)
)
(PUTPROPS AREDIT COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (8388 18328 (AR.FORM 8398 . 8683) (AR.FORM.GROUP.CREATE 8685 . 11708) (AR.FORM.CREATE 
11710 . 14971) (AR.FORM.ICONFN 14973 . 15219) (AR.BUTTON.OBJ.CREATE 15221 . 17171) (AR.PROTECT.WARNING
 17173 . 17365) (AR.INSTALL.TEDITSTREAM 17367 . 17966) (AR.KILL.ATTACHED.TEDIT.CLOSEFN 17968 . 18326))
 (18362 26952 (AR.BUTTON.GET.MENU 18372 . 18711) (AR.BUTTON.GET.SUBMENU 18713 . 19407) (
AR.BUTTONFN.DOMENU 19409 . 20292) (AR.BUTTONFN.DOSUBMENU 20294 . 20754) (AR.RESET.SEL 20756 . 21611) (
AR.REPLACE.FIELD.VAL 21613 . 22593) (AR.GET.ASSOCIATED.MENU.VAL 22595 . 22974) (AR.BUTTONFN.SELFIELD 
22976 . 23411) (AR.BUTTONFN.OFFER.DEFAULT 23413 . 24208) (AR.MAP.BUTTONS 24210 . 24798) (
AR.FIND.BUTTON 24800 . 25128) (AR.GET.BUTTON.FIELD.AS.TEXT 25130 . 25887) (AR.GET.BUTTON.FIELD.SHAPE 
25889 . 26675) (AR.GET.NUMBER.FIELD 26677 . 26950)) (26995 31179 (AR.FORM.MENU.BUTTONFN 27005 . 27263)
 (AR.FORM.MENU.ACTIONFN 27265 . 29030) (AR.FORM.PROGRAMMATIC.GET 29032 . 29168) (
AR.FORM.PROGRAMMATIC.PUT 29170 . 29312) (AR.DISCONNECT.WINDOW 29314 . 29482) (AR.RECONNECT.WINDOW 
29484 . 29906) (AR.MARK.ACTIVE 29908 . 30043) (AR.TOBJ.ACTIVEP 30045 . 30184) (
AR.FORM.MENU.TITLEMENUFN 30186 . 30671) (AR.MENU.CR.FN 30673 . 30834) (AR.GET.MENU.FROM.MAIN.WINDOW 
30836 . 31021) (AR.CONFIRM 31023 . 31177)) (31202 33954 (AR.MENU.FN.CLEAR 31212 . 31610) (
AR.FORM.CLEAR 31612 . 32566) (AR.FORM.SET.TO.EMPTY 32568 . 33091) (AR.DELETE.FIELD.VAL 33093 . 33952))
 (33975 43470 (AR.MENU.FN.GET 33985 . 34534) (AR.GET.AR 34536 . 36754) (AR.FETCH.AND.PARSE.AR 36756 . 
37733) (AR.SET.FORM.NUMBER 37735 . 38577) (AR.GET.SCRATCH.STREAM 38579 . 38909) (AR.COPY.AND.INDEX.AR 
38911 . 40536) (AR.MALFORMED.AR 40538 . 40648) (AR.TEXTSTREAM.LOAD 40650 . 43148) (AR.REPLACE.FILL.INS
 43150 . 43468)) (43491 59885 (AR.MENU.FN.PUT 43501 . 46837) (AR.MENU.FN.PUT&GET 46839 . 47015) (
AR.MENU.FN.PUT&GETNEXT 47017 . 47159) (AR.FORM.SAVE 47161 . 49619) (AR.GET.SUBMIT.NUM 49621 . 50928) (
AR.FIND.EDIT.CHANGES 50930 . 53546) (AR.NOTE.FIELD.CHANGED 53548 . 55279) (AR.SEND.MESSAGE 55281 . 
57676) (AR.COPY.BUTTON.FIELD 57678 . 58685) (AR.UPDATE.AR.INFO 58687 . 59670) (AR.PUT.FAILED 59672 . 
59883)) (59886 62218 (AR.CHECK.FIELDS 59896 . 60773) (AR.CHECK.MENU 60775 . 61223) (
AR.CHECK.SHORTSTRING 61225 . 61498) (AR.CHECK.SUBMENU 61500 . 62216)) (62243 65418 (
AR.FORM.GET/PUT.FILE 62253 . 62906) (AR.GET.NEXT 62908 . 63926) (AR.FORM.FILL.IN.DEFAULTS 63928 . 
65104) (AR.CURRENT.LISP.VERSION 65106 . 65416)) (65440 67664 (AR.PROMPT 65450 . 65706) (
AR.PROMPT.PRINT 65708 . 66112) (AR.PROMPT.CLEAR 66114 . 66235) (AR.GET.FILENAME 66237 . 66782) (
AR.READ.NUMBER 66784 . 67111) (AR.FILENAME 67113 . 67245) (AR.READ.BYTES 67247 . 67512) (AR.USERNAME 
67514 . 67662)) (67747 72497 (TEDIT.FAST.RAW.INCLUDE 67757 . 69694) (AR.PIECE.CHANGED 69696 . 72495)) 
(72530 72990 (AR.UNSELECT.ITEM 72540 . 72988)) (73024 79494 (AR.DISPLAY 73034 . 73653) (AR.HARDCOPY 
73655 . 75981) (AR.DISPLAY.TEXTSTREAM 75983 . 79492)))))
STOP
\ No newline at end of file
diff --git a/internal/library/AREDIT.TEDIT b/internal/library/AREDIT.TEDIT
new file mode 100644
index 00000000..942589a4
--- /dev/null
+++ b/internal/library/AREDIT.TEDIT
@@ -0,0 +1,14 @@
+
The AREDIT Interlisp bug database system

author: Michael Sannella
files: {eris}<lispcore>library>AREDIT.DCOM
doc: {eris}<lispcore>library>AREDIT.TEDIT
uses: All Tedit files

The file AREDIT.DCOM contains a number of tools useful for examining, editing, and submitting ARs ("Action Requests") related to the Interlisp-D system.  These tools are loosely based on the "Adobe" tools in the Tajo environment.  The Interlisp-D support group uses this system to keep track of the state of outstanding bug reports.  There are currently over 2000 ARs in the database.

These tools can be used from any machine running Interlisp-D which can establish a leaf connection to the Phylex: file server, where the database files are currently stored, and the ERIS file server.

After loading AREDIT.DCOM, the user can create two types of windows: AR edit forms and AR Query forms.

The AR Edit Form

An AR edit form is used to examine, edit, and submit ARs.  To create an AR Edit Form, evaluate (AR.FORM).  Interlisp will prompt you to specify a region for the form window -- the best size to give it is one about half the width of the screen and at least half the height of the screen.  The form window which will appear contains three subwindows: (1) On the top is the message subwindow, where prompts and status messages are printed; (2) in the middle is the command subwindow, a menu of commands for editing / submitting ARs; (3) on the bottom is the form subwindow, where the information in an AR is displayed.

The command subwindow contains the following commands:

New -- Buttoning this word clears the fields of the AR in the form subwindow.  Some fields (Source, Submitter, Status) are initialized to appropriate values for a new AR.

Get -- Buttoning this retrieves the AR whose number follows "Number:" in the command subwindow.

Put -- Buttoning this will either store an edited AR, or submit a new AR.  Which one (submit new or store old) depends on whether the last operation was "New" or "Get".  If the current AR displayed was retrieved with "Get", then "Put" will store it as the old AR.  If this AR was built up from scratch after buttoning "New", then "Get" will submit is as a new AR.  The title of the form subwindow gives an indication of what state the form is in: if it says "New Bug Report", then "Put" will submit it.  If it says "Editing AR xxx", then "Put" will store it.  [There are plans to improve this interface]

Number: -- This is a text field just like text fields in the form window (see below) used to specify the number used by "Get".  Buttoning the word "Number:" will pending-delete-select the value of the field, so you can delete it and insert a new number.  If the character carriage-return is typed, then a "Get" is automatically done on the value of this field.  This is faster than typing a number, and buttoning "Get".


The form subwindow contains a large number of fields.  The meaning of these fields is described in XXX.  The value of these fields can be edited as follows:

"Enumerated fields" can only contain certain values.  These are indicated in the form subwindow by field names followed by curly-braces "{}".  To change the value of one of these fields, button the field name; a menu of permissable values will appear; select a value; it will be inserted between the braces.

[note: Some of the enumerated field values are dependent on other fields.  For example, the values of "Subsystem:" depend on the value of "System:" -- if the "System:" value is changed, the "Subsystem:" value is automatically set to NIL.  The fields with this relationship are System:/Subsystem: and Machine:/Disk:.]

"Text fields" can contain arbitrary text.  These fields do not have braces after the field name.  The text can be edited using normal Tedit editing.  Buttoning the field name will pending-delete-select the entire field value, which allows the whole field to be easily deleted.

[note: Currently, stored ARs only contain straight text.  Any tedit formatting information put into an AR will be lost when the AR is stored.  Image objects (like bitmaps) are also not stored.]

[note: A few of the text fields, like "Number:", are read only --- they cannot be edited by the user.]

[note: in older versions of AREDIT, some text fields (such as "Attn:" could only contain a certain number of characters.  The user could type as many characters as he wanted, but an error would occur when the "Put" command was executed.  This has now been changed --- any text field can contain an arbitrary number of characters.]


The AR Query Form

An AR Query Form is used to search the AR database for all ARs with particular characteristics.  One can search for all ARs with a given name in the "Attn:" field, all ARs which have Status: = Open, etc.  These ARs can be sorted, and a summary of the selected ARs can be printed into a file.

To create an AR query form, evaluate (AR.QFORM.CREATE).  Interlisp will prompt for a region (the default size is ok), and create a window with three subwindows:  (1) on top, a message subwindow, for printing prompts and messages;  (2) in the middle, a browser subwindow, used for displaying the ARs seleced by a query; (3) on the bottom, the AR query command subwindow, containing a number of commands and fields.

The Ar Query command subwindow contains the following fields/ commands:

Query List: -- This field is used to specify which ARs the "Query" command will search for.  This field should be filled with an AR query spec, which has one of the following forms:

(<field> HAS <val>) searches for all ARs whose text field <field> contains <val>.  <string> may either be an Interlisp string or an atom.  The search is case-independent: foo matches Foo matches FOO.

(<field> IS <val>) searches for all ARs whose enumerated field <field> has the value <val>.

(AND <spec1> <spec2> ... <specN>) returns all ARs satisfying ALL of the given specs.

(OR <spec1> <spec2> ... <specN>) returns all ARs satisfying ANY of the given specs.

[note: an implicit (AND) is wrapped around the value of the "Query List:" field, so just giving a number of specs will AND them together.]


Not every AR field can be searched for in the same way:  some can only be searched with HAS, some can only be searched with IS, and some (like the Description: field) cannot be searched at all.  To find out the possible query specs, button the words "Query List:" --- this will put up a menu of all of the permitted searching options.  Some of these menu items have submenues.  When one of the options is selected, it is added at the end of the value of this field.

Examples:

Query List: (Subject: HAS foo)
Searches for all ARs whose subject contains the string "foo".  

Query List: (Status: IS Open) (Attn: HAS sannella)
Searches for all open ARs which have "sannella" in the Attn: field.

Query List: (OR (Status: IS Declined) (Status: IS Superceded) )
Searches for all ARs with Status: either Declined or Superceded.

Sort List: -- This field determines how the Query-ed ARs will be sorted.  Currently, ARs can only be sorted by the values of enumerated fields.  Buttoning the words "Sort List:" will put up a menu of the permitted field names -- selecting one will add it to the value of this field.

Example:

Sort List: Status: Priority:
This will sort first by the Status: field, and then by the Priority: field.

[note: After sorting by all given fields, if two ARs are the same, they are sorted by AR number.  Therefore, if this field is left blank, the queried ARs will be in numerical order]

Query -- Buttoning this command will initiate the query specified by the "Query List:" field, and sort it according to the value of the "Sort List:" field.  While the query is in progress, the AR query command subwindow is greyed-out.  When the query is completed, the numbers, subjects, etc of the ARs which have been found are displayed in the AR query browser subwindow.  This window can be scrolled both vertically and horizontally.


Print File: -- This field can be filled in with a file name, which is used to specify the file that the Print command should store a report.  If left blank, a window will pop up on the screen, and the information will be displayed there.


Print -- This prints a detailed summary of all of the ARs from the last Query into the file given in the Print File: field.  



To generate and print a summary of a selected group of ARs, fill in the Qury List: and Sort List: fields, select Query and wait for the query to complete, fill in the Print File: field, and select Print.  The summery is rather wide -- it may be a good idea to use the LANDPRESS package to printit out sideways on a printer.


The AR query browser window:

This window shows a short summary (one line each) of the ARs that have been queried.  Left-buttoning one of the AR lines will call AR.SHOW on that AR, to display it.  Middle-buttoning an AR line will "Get" that AR into a specified AR edit form window.


Background menu commands:

When AREDIT is loaded, the item "AREDIT" is added to the background menu, with a number of subitems.  These are interpreted as follows:

AREDIT -- Creates a new AR edit form, initially cleared.

	New AR Form -- Same as AREDIT

	Load AR Form -- prompts the user for a number, and creates a new AR edit form, with the specified AR number loaded initially.

	AR.SHOW -- prompts the user for a number, and calls AR.SHOW, an old version of AREDIT which quickly displays the contents of a given AR.  It prompts for a window region the first time it is used -- thereafter it uses the same window.

	AR Query Form -- Creates a new AR query form.


Auxiliary AR edit form commands.

Pressing the left mouse button in the title bar of the AR Edit form command subwindow will bring up a menu of less-used commands:

Clear -- Clears ALL the fields of the current AR.  Similar to New, except that non of the fields like Source:, etc., are filled in.  This is useful when you are submitting an AR for someone else.

New
Get
Put -- the same as the Commands in the edit command subwindow.

Put&Get -- prompts the user for a number, Puts the current AR, and Gets the given numbered AR.  Useful when scanning through a number of ARs.

GetFromFile -- Prompts the user for a file name, and loads the information from that file into the AR edit form subwindow.  If this file is not in the right format, an error will be generated. 

PutToFile -- Prompts the user for a file name, and stores the information from the AR into that file.


Locally caching the AR index.

All AR query operations use the information in the "AR Index" file.  This file, which is updated every few days, is stored as {eris}<lispars>AR.INDEX.  To speed up Query operations, this file can be copied to a local file server, or the local hard disk.  Warning: this file is currently ~700 IFS pages long, and it will undoubtedly get larger.  Also, it is the responsibility of the user to make sure that they update their local version of AR.INDEX when the master copy is updated.

To use a local version of AR.INDEX, give the file name as an argument to AR.QFORM.CREATE:

(AR.QFORM.CREATE '{DSK}AR.INDEX).


Global Variables that control AREDIT

The following are global variables that can be set to alter the operation of AREDIT.  These are the only global variables that it is safe to change.

AR.ENTRY.LIST.WINDOW.FIELDS  -- Controls which fields are displayed in the AR query browser window, along with the widths of the fields.

AR.ENTRY.LIST.PRINT.FIELDS  -- Controls the fields displayed by the Print command of the AR query form.

AR.ENTRY.LIST.PRINT.MULTILINE.FLAG -- if non-NIL, the Print command of the AR query form will print all of the characters in each field, using multiple lines for those field values bigger than the field width allowed.  If NIL, each AR will use only one line, truncating any field values that are too big.

(H��((���(MODERN
+MODERN
+CLASSICCLASSIC
+CLASSICCLASSIC
+) #$
+EO�Y7:�4	V	�6?r�ih��<�gK�_%hH1u�J!4 4s��
+@&D3A
+�
+k	
+	�E4
+"]�C
+H
+
+1B	/�?0a3r-�
!�9%W<#H�	]~$"' %�nN".m�z�
\ No newline at end of file
diff --git a/internal/library/ARHACK b/internal/library/ARHACK
new file mode 100644
index 00000000..41bfde0d
--- /dev/null
+++ b/internal/library/ARHACK
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "12-Sep-91 19:04:19" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>ARHACK.;3| 33540  

      changes to%:  (VARS ARHACKCOMS)
                    (FNS OBSOLETE.MANY.ARS)

      previous date%: "15-Jun-90 10:53:51" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>ARHACK.;2|)


(* ; "
Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT ARHACKCOMS)

(RPAQQ ARHACKCOMS
       ((COMS 
              (* ;; "FNS for finding things out about lots of ARs")

              (FNS AR.GET.PLIST)
                                                             (* ; 
                                                           "Grab specified field from set of ARs:")
              (FNS NAB.TEST.CASES)
                                                             (* ; 
                                                           "Find ARs edited before a given date:")
              (FNS LAST-CHANGED-BEFORE))
        (COMS 
              (* ;; "For nabbing AR information from tds")

              (FNS AR.GET.SUBMITS.FROM.TDS AR.GET.FIXES.FROM.TDS AR.GET.ARS.FROM.TDS COLLECT-FIXES 
                   COLLECT-SUBMISSIONS))
        (COMS 
              (* ;; "Bulk changes to the AR database (fixes, closing, etc.)")

              
              (* ;; "Function to mark lots of ARs fixed in one sweep.")

              (FNS FIX.MANY.ARS FIX.NO.RELEASE.NOTE)
              
              (* ;; 
          "Function for making changes to lots of ARs in one sweep; less convenient than above fn:")

              
              (* ;; 
            "the form of CHANGE.SPEC is a list like ((1 Status: Closed Attn: %"%") (234 Attn: Me))")

              (FNS CHANGE.MANY.ARS)
              
              (* ;; "Function for closing lots of ARs, to mark lots of ARs obsolete.")

              (FNS CLOSE.MANY.ARS OBSOLETE.MANY.ARS)
              
              (* ;; "Functions for counting info about ARs")

              (FNS LIST.NUM.STATUS.PRIORITY COUNT-ARS COUNT-BY-WEEK BREAKOUT-ARS-BY-TYPE))
        (COMS 
              (* ;; "Functions for making a summary of all feature requests or hopefully-type ARs.")

              (FNS FEATURE.SUMMARY HOPE.SUMMARY OPEN.SUMMARY FIXED.SUMMARY))
        [COMS 
              (* ;; 
  "Function for making lyric relevant summaries of Absolutely bugs, and a listing of all open ARs.")

              (FNS ABSOLUTELY.SUMMARIES ABS.SUMMARY)
              (INITVARS (AR.ABSOLUTELY.HACKER.NAMES '(Bane Biggs Burton Charnley Cude Daniels Fischer
                                                           Kelley Murage Pavel Pedersen Shih Snow Sye
                                                           SCPeters RMRichardson Sybalsky vanMelle 
                                                           Woz]
        (COMS                                                (* ; 
 "Function for caching the ar index locally, and causing all later queries to use the local cache.")
              (INITVARS (LOCAL-CACHE-ORIGINAL-AR-INDEX-NAME AR.INDEX.DEFAULT.FILE.NAME))
              (FNS CACHE-ARINDEX))
        (COMS 
              (* ;; 
"Fns for moving closed/obsolete/etc ar files from main directory to the <ClosedLispARs> directory.")

              (FNS MAKE-AR-FILENAME MOVE-CLOSED-ARS))
        (COMS 
              (* ;; "These names superseded by other functions on this file or on AREDIT")

              (FNS GET.NUMS.FROM.QUERY LANDSCAPE.QUERY.WINDOW HARDCOPY.ARS))
        (COMS 
              (* ;; "Function for querying, and getting a list of the selected AR numbers.  In effect, this is a programmatic interface to AR.QUERY.")

              (FNS GET-SELECTED-AR-NUMBERS))
        (COMS                                                (* ; 
                                                   "Functions for making release notes & the like:")
              
              (* ;; "NOTES takes a list of items (AR# subj-string relnote-string) and prints them one to a line, with tab after AR# &  new-line (not new-para) before relnote into a TEdit.")

              (FNS NOTES)
              (FNS KNOWN-BUG-LIST FIXED-BUG-LIST))))



(* ;; "FNS for finding things out about lots of ARs")

(DEFINEQ

(AR.GET.PLIST
(LAMBDA (ARLIST ITEMS AS-STRINGS? SCRATCH.STREAM) (* ; "Edited 23-Feb-88 17:42 by bvm") (* ;; "Read ITEMS about each AR in ARLIST.  RETURN a list  of (AR# .items)...") (OR SCRATCH.STREAM (SETQ SCRATCH.STREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (for NUM/OR/FILE in ARLIST bind MAP CONDITION SPEC STR collect (CL:MULTIPLE-VALUE-SETQ (MAP CONDITION) (AR.FETCH.AND.PARSE.AR NUM/OR/FILE SCRATCH.STREAM ITEMS)) (* ; "Fetch desired fields into scratch stream, map shows where") (CONS NUM/OR/FILE (if CONDITION then (CL:FORMAT PROMPTWINDOW "~%%Can't read AR ~A because: ~A" NUM/OR/FILE CONDITION) NIL else (for ITEMNAME in ITEMS collect (if (SETQ SPEC (CDR (ASSOC ITEMNAME MAP))) then (* ; "Spec = (ptr length)") (SETFILEPTR SCRATCH.STREAM (CAR SPEC)) (SETQ STR (ALLOCSTRING (CADR SPEC))) (\BINS SCRATCH.STREAM (fetch (STRINGP BASE) of STR) 0 (CADR SPEC)) (if AS-STRINGS? then STR else (MKATOM STR))))))))
)
)



(* ; "Grab specified field from set of ARs:")

(DEFINEQ

(NAB.TEST.CASES
(LAMBDA (FIELD-TO-GET NUMS.OR.QFORMWINDOW) (* ; "Edited 23-Feb-88 17:46 by bvm") (LET ((NUMS (OR (LISTP NUMS.OR.QFORMWINDOW) (AR.NUMS.FROM.QUERY NUMS.OR.QFORMWINDOW))) (SCRATCH (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (ITEMS (LIST FIELD-TO-GET (QUOTE Subject%:))) TEXT INFO) (printout T "will examine AR numbers: " NUMS T T) (for NUM in NUMS when (AND (SETQ TEXT (CADR (SETQ INFO (CAR (AR.GET.PLIST (LIST NUM) ITEMS T SCRATCH))))) (> (NCHARS TEXT) 0)) do (printout T |.I5| NUM %,,, (CADDR INFO) T FIELD-TO-GET %,,, TEXT T T))))
)
)



(* ; "Find ARs edited before a given date:")

(DEFINEQ

(LAST-CHANGED-BEFORE
(LAMBDA (ARLIST DATE-STRING) (* ; "Edited 23-Feb-88 17:18 by bvm") (* ;; "Given a list of AR numbers, ARLIST, returns a list of those ARs that were last edited before the date specified in DATE-STRING (which must be acceptable to IDATE).") (for TRIPLE in (AR.GET.PLIST ARLIST (QUOTE (Edit-Date%: Date%:)) T) bind (DATE _ (IDATE DATE-STRING)) when (<= (IDATE (if (> (NCHARS (CADR TRIPLE)) 0) then (* ; "Use edit date") (CADR TRIPLE) else (* ; "Not edited, so use submit date") (CADDR TRIPLE))) DATE) collect (CAR TRIPLE)))
)
)



(* ;; "For nabbing AR information from tds")

(DEFINEQ

(AR.GET.SUBMITS.FROM.TDS
(LAMBDA (FILENAME) (* ; "Edited 23-Feb-88 18:15 by bvm") (* ;; "Gather the list of ARs that have been submitted from the %"Tool Driver Script%" file, where AREDIT makes note of edits that people make.") (AR.GET.ARS.FROM.TDS FILENAME (QUOTE SUBMIT)))
)

(AR.GET.FIXES.FROM.TDS
(LAMBDA (FILENAME) (* ; "Edited 23-Feb-88 18:16 by bvm") (* ;; "Gather the list of ARs from the %"Tool Driver Script%" file whose status has changed away from Open") (AR.GET.ARS.FROM.TDS FILENAME (QUOTE EDIT) (FUNCTION (LAMBDA (AR# INFO) (OR (STRPOS "->Fixed" INFO) (STRPOS "->Declined" INFO) (STRPOS "->Superseded" INFO) (STRPOS "->Obsolete" INFO))))))
)

(AR.GET.ARS.FROM.TDS
(LAMBDA (FILENAME TYPE PREDFN) (* ; "Edited 23-Feb-88 18:13 by bvm") (* ;; "Reads the TDS file and returns a list (AR# changeInfo) for all ars of TYPE (EDIT, SUBMIT or NIL for either).  If PREDFN is supplied, returns only those for which (predfn AR# changeInfo) is true") (LET ((FILE (OPENSTREAM (OR FILENAME AR.INFO.FILE.NAME) (QUOTE INPUT) (QUOTE OLD))) (*READTABLE* FILERDTBL)) (CL:UNWIND-PROTECT (bind (SEARCHSTR _ (CONCAT "  --  (" (OR TYPE ""))) AR# INFO while (FILEPOS SEARCHSTR FILE NIL NIL NIL T UPPERCASEARRAY) when (PROGN (* ; "Line looks like  --  (EDIT AR# name date etc), where for old aredit there were parens around the other info") (if (NULL TYPE) then (* ; "Skip edit type") (SKREAD FILE)) (SETQ AR# (CL:READ FILE)) (SETQ INFO (if (EQ (CHCON1 (SETQ INFO (CL:READ-LINE FILE))) (CHARCODE "(")) then (* ; "Old kind") (SUBSTRING INFO 2 -3) else (* ; "New kind, just drop the last paren") (SUBSTRING INFO 1 -2))) (OR (NULL PREDFN) (CL:FUNCALL PREDFN AR# INFO))) collect (LIST AR# INFO)) (CLOSEF FILE))))
)

(COLLECT-FIXES
(LAMBDA NIL (* ; "Edited 23-Apr-87 07:22 by jds") (for FILE in (DIRECTORY (QUOTE {ERIS}<LISPARS>*.TDS-PROCESSED)) join (AR.GET.FIXES.FROM.TDS FILE)))
)

(COLLECT-SUBMISSIONS
(LAMBDA NIL (* ; "Edited 23-Apr-87 07:21 by jds") (for FILE in (DIRECTORY (QUOTE {ERIS}<LISPARS>*.TDS-PROCESSED)) join (AR.GET.SUBMITS.FROM.TDS FILE)))
)
)



(* ;; "Bulk changes to the AR database (fixes, closing, etc.)")




(* ;; "Function to mark lots of ARs fixed in one sweep.")

(DEFINEQ

(FIX.MANY.ARS
(LAMBDA (ARLIST STATUS NO.RELEASE.NOTE) (* ; "Edited  5-Aug-88 11:04 by bvm") (* ;; "ARLIST is a list of AR numbers.  Each AR on the list will be marked FIXED, or will be marked with the marking STATUS.  Also moves the ATTN field into the ASSIGNED-TO field and clears the ATTN field.  If NO.RELEASE.NOTE is true, fills release note field with %"none required%"") (if (AND STATUS (NOT (MEMBER STATUS (QUOTE (New Open Fixed Closed Declined Superseded Incomplete Obsolete Wish))))) then (\ILLEGAL.ARG STATUS)) (for AR# in ARLIST bind (ARFORM _ (AR.SELECT.WINDOW "Select AR form")) ARMENU BAD.ARS first (SETQ ARMENU (AR.GET.MENU.FROM.MAIN.WINDOW ARFORM)) do (printout T "Fixing " AR# T) (COND ((NOT (NLSETQ (LET (NEWVALUE) (AR.FORM.PROGRAMMATIC.GET ARMENU AR#) (SETQ NEWVALUE (CL:STRING-TRIM (QUOTE (#\Space)) (AR.GET.BUTTON.FIELD.AS.TEXT ARFORM (QUOTE Attn%:)))) (* ; "Attn field, trimmed of spaces") (AR.REPLACE.FILL.INS ARFORM (BQUOTE ((Status%: (\, (OR STATUS (QUOTE Fixed)))) (Attn%: "") (\,@ (if (> (NCHARS NEWVALUE) 0) then (* ; "Only change the ASSIGNED-TO field if the ATTN field had something in it.") (BQUOTE ((|Assigned To:| (\, NEWVALUE)))))) (\,@ (if (AND NO.RELEASE.NOTE (NOT (> (NCHARS (CL:STRING-TRIM (QUOTE (#\Space)) (AR.GET.BUTTON.FIELD.AS.TEXT ARFORM (QUOTE |Release Note:|)))) 0))) then (* ; "Say none needed if there isn't a note yet") (BQUOTE ((|Release Note:| "None required")))))))) (AR.FORM.PROGRAMMATIC.PUT ARMENU)))) (printout T "error reading AR!!!" T) (push BAD.ARS AR#))) (TEDIT.STREAMCHANGEDP (TEXTSTREAM ARFORM) T) finally (if BAD.ARS then (printout T "bad ARs: " BAD.ARS T))))
)

(FIX.NO.RELEASE.NOTE
(LAMBDA (ARLIST STATUS) (* ; "Edited 23-Feb-88 18:42 by bvm") (* ;; "ARLIST is a list of AR numbers.  Each AR on the list will be marked FIXED, and a note needing no release note..  Also moves the ATTN field into the ASSIGNED-TO field and clears the ATTN field. ") (FIX.MANY.ARS ARLIST STATUS T))
)
)



(* ;; "Function for making changes to lots of ARs in one sweep; less convenient than above fn:")




(* ;; "the form of CHANGE.SPEC is a list like ((1 Status: Closed Attn: %"%") (234 Attn: Me))")

(DEFINEQ

(CHANGE.MANY.ARS
(LAMBDA (CHANGE.SPEC) (* ; "Edited  5-Aug-88 13:14 by bvm") (* ;; "the form of CHANGE.SPEC is a list like ((1 Status: Closed Attn: %"%") (234 Attn: Me))") (LET* ((ARFORM (AR.SELECT.WINDOW "Select AR form")) (ARMENU (AR.GET.MENU.FROM.MAIN.WINDOW ARFORM)) (NCHANGES (LENGTH CHANGE.SPEC)) BAD.ARS) (for CHANGE in CHANGE.SPEC as CNT from 1 do (printout T "doing change: " CHANGE "    (" |.I1| CNT "/" |.I1| NCHANGES ")" T) (if (NOT (NLSETQ (PROGN (AR.FORM.PROGRAMMATIC.GET ARMENU (CAR CHANGE)) (AR.REPLACE.FILL.INS ARFORM (for X on (CDR CHANGE) by (CDDR X) collect (LIST (CAR X) (CADR X)))) (AR.FORM.PROGRAMMATIC.PUT ARMENU)))) then (printout T "error reading AR!!!" T) (push BAD.ARS CHANGE)) (TEDIT.STREAMCHANGEDP (TEXTSTREAM ARFORM) T) finally (printout T "bad ARs: " BAD.ARS T))))
)
)



(* ;; "Function for closing lots of ARs, to mark lots of ARs obsolete.")

(DEFINEQ

(CLOSE.MANY.ARS
(LAMBDA (ARLIST) (* ; "Edited  5-Aug-88 11:07 by bvm") (* ;; "ARLIST is a list of AR numbers.  Each AR on the list will be marked CLOSED.") (DECLARE (SPECVARS AR.NO.MESSAGE.FLG)) (LET* ((AR.NO.MESSAGE.FLG T) (ARFORM (AR.SELECT.WINDOW "Select AR form")) (ARMENU (AR.GET.MENU.FROM.MAIN.WINDOW ARFORM)) BAD.ARS) (for AR# in ARLIST as CNT from 1 do (printout T "Closing " AR# T) (COND ((NLSETQ (PROGN (AR.FORM.PROGRAMMATIC.GET ARMENU AR#) (COND ((STRING-EQUAL "Fixed" (AR.GET.BUTTON.FIELD.AS.TEXT ARFORM (QUOTE Status%:))) (AR.REPLACE.FILL.INS ARFORM (BQUOTE ((Status%: Closed)))) (AR.FORM.PROGRAMMATIC.PUT ARMENU)) (T (PRINTOUT T "AR not Fixed first:  " AR# T) (push BAD.ARS AR#))) NIL)) NIL) (T (printout T "error reading AR!!!" T) (push BAD.ARS AR#))) (TEDIT.STREAMCHANGEDP (TEXTSTREAM ARFORM) T) finally (printout T "ARs not closed: " (COND (BAD.ARS) (T "None.")) T))))
)

(OBSOLETE.MANY.ARS
  [LAMBDA (ARLIST)                                       (* ; "Edited 12-Sep-91 18:57 by jds")

    (* ;; "ARLIST is a list of AR numbers.  Each AR on the list will be marked OBSOLETE, and any ATTN will be removed..")

    (DECLARE (SPECVARS AR.NO.MESSAGE.FLG))
    (LET* ((AR.NO.MESSAGE.FLG T)
           (ARFORM (AR.SELECT.WINDOW "Select AR form"))
           (ARMENU (AR.GET.MENU.FROM.MAIN.WINDOW ARFORM))
           BAD.ARS)
          (for AR# in ARLIST as CNT from 1
             do (printout T "Closing " AR# T)
                   (COND
                      ((NLSETQ (PROGN (AR.FORM.PROGRAMMATIC.GET ARMENU AR#)
                                      [AR.REPLACE.FILL.INS ARFORM `((Status%: Obsolete)
                                                                    (Attn%: ""]
                                      (AR.FORM.PROGRAMMATIC.PUT ARMENU)
                                      NIL))
                       NIL)
                      (T (printout T "error reading AR!!!" T)
                         (push BAD.ARS AR#)))
                   (TEDIT.STREAMCHANGEDP (TEXTSTREAM ARFORM)
                          T) finally (printout T "ARs not obsoleted: " (COND
                                                                              (BAD.ARS)
                                                                              (T "None."))
                                                T])
)



(* ;; "Functions for counting info about ARs")

(DEFINEQ

(LIST.NUM.STATUS.PRIORITY
(LAMBDA (ARLIST FIELDS) (* ; "Edited 23-Feb-88 18:51 by bvm") (* ;; "ARLIST is a list of AR numbers.  Returns a list of entries of the form (# fieldValue fieldValue ...). where each field is one of the names in FIELDS.") (AR.GET.PLIST ARLIST (OR FIELDS (QUOTE (Status%: Priority%: |Problem Type:| System%: Subsystem%:))) T))
)

(COUNT-ARS
(LAMBDA (ARLIST) (* ; "Edited 23-Apr-87 08:10 by jds") (PRINTOUT T T T "For Documentation:" T T) (bind FIXED NEW OPEN OTHER ABS HOPE F/A F/H F/O O/A O/H O/O first (SETQ FIXED 0) (SETQ NEW 0) (SETQ OPEN 0) (SETQ OTHER 0) (SETQ ABS 0) (SETQ HOPE 0) (SETQ F/A 0) (SETQ F/H 0) (SETQ F/O 0) (SETQ O/A 0) (SETQ O/H 0) (SETQ O/O 0) for AR in ARLIST when (MEMBER (QUOTE Documentation) AR) do (SELECTQ (CADR AR) ((New Open) (add NEW 1) (SELECTQ (CADDR AR) (Absolutely (add ABS 1) (add O/A 1)) (Hopefully (add HOPE 1) (add O/H 1)) (PROGN (add OTHER 1) (add O/O 1)))) ((Fixed Declined Obsolete Incomplete Superseded) (add FIXED 1) (SELECTQ (CADDR AR) (Absolutely (add ABS 1) (add F/A 1)) (Hopefully (add HOPE 1) (add F/H 1)) (PROGN (add OTHER 1) (add F/O 1)))) (SELECTQ (CADDR AR) (Absolutely (add ABS 1)) (Hopefully (add HOPE 1)) (add OTHER 1))) finally (PRINTOUT T "      NEW     FIXED" T "ABS  " O/A "     " F/A T "HOPE " O/H "     " F/H T "OTHR " O/O "     " F/O T T)) (* ;; "Now FEATURES") (PRINTOUT T T T T "For FEATURES:" T T) (bind FIXED NEW OPEN OTHER ABS HOPE F/A F/H F/O O/A O/H O/O first (SETQ FIXED 0) (SETQ NEW 0) (SETQ OPEN 0) (SETQ OTHER 0) (SETQ ABS 0) (SETQ HOPE 0) (SETQ F/A 0) (SETQ F/H 0) (SETQ F/O 0) (SETQ O/A 0) (SETQ O/H 0) (SETQ O/O 0) for AR in ARLIST when (EQ (QUOTE Feature) (CL:FOURTH AR)) do (SELECTQ (CADR AR) ((New Open) (add NEW 1) (SELECTQ (CADDR AR) (Absolutely (add ABS 1) (add O/A 1)) (Hopefully (add HOPE 1) (add O/H 1)) (PROGN (add OTHER 1) (add O/O 1)))) ((Fixed Declined Obsolete Incomplete Superseded) (add FIXED 1) (SELECTQ (CADDR AR) (Absolutely (add ABS 1) (add F/A 1)) (Hopefully (add HOPE 1) (add F/H 1)) (PROGN (add OTHER 1) (add F/O 1)))) (SELECTQ (CADDR AR) (Absolutely (add ABS 1)) (Hopefully (add HOPE 1)) (add OTHER 1))) finally (PRINTOUT T "      NEW     FIXED" T "ABS  " O/A "     " F/A T "HOPE " O/H "     " F/H T "OTHR " O/O "     " F/O T T)) (* ;; "Now real bugs") (PRINTOUT T T T T "Now performance problems: " T T) (bind FIXED NEW OPEN OTHER ABS HOPE F/A F/H F/O O/A O/H O/O first (SETQ FIXED 0) (SETQ NEW 0) (SETQ OPEN 0) (SETQ OTHER 0) (SETQ ABS 0) (SETQ HOPE 0) (SETQ F/A 0) (SETQ F/H 0) (SETQ F/O 0) (SETQ O/A 0) (SETQ O/H 0) (SETQ O/O 0) for AR in ARLIST when (EQ (QUOTE Performance) (CL:FOURTH AR)) do (SELECTQ (CADR AR) ((New Open) (add NEW 1) (SELECTQ (CADDR AR) (Absolutely (add ABS 1) (add O/A 1)) (Hopefully (add HOPE 1) (add O/H 1)) (PROGN (add OTHER 1) (add O/O 1)))) ((Fixed Declined Obsolete Incomplete Superseded) (add FIXED 1) (SELECTQ (CADDR AR) (Absolutely (add ABS 1) (add F/A 1)) (Hopefully (add HOPE 1) (add F/H 1)) (PROGN (add OTHER 1) (add F/O 1)))) (SELECTQ (CADDR AR) (Absolutely (add ABS 1)) (Hopefully (add HOPE 1)) (add OTHER 1))) finally (PRINTOUT T "      NEW     FIXED" T "ABS  " O/A "     " F/A T "HOPE " O/H "     " F/H T "OTHR " O/O "     " F/O T T)) (* ;; "Now real bugs") (PRINTOUT T T T T " And bugs: " T T) (bind FIXED NEW OPEN OTHER ABS HOPE F/A F/H F/O O/A O/H O/O first (SETQ FIXED 0) (SETQ NEW 0) (SETQ OPEN 0) (SETQ OTHER 0) (SETQ ABS 0) (SETQ HOPE 0) (SETQ F/A 0) (SETQ F/H 0) (SETQ F/O 0) (SETQ O/A 0) (SETQ O/H 0) (SETQ O/O 0) for AR in ARLIST when (NOT (OR (MEMBER (QUOTE Documentation) AR) (EQ (QUOTE Feature) (CL:FOURTH AR)) (EQ (QUOTE Performance) (CL:FOURTH AR)))) do (SELECTQ (CADR AR) ((New Open) (add NEW 1) (SELECTQ (CADDR AR) (Absolutely (add ABS 1) (add O/A 1)) (Hopefully (add HOPE 1) (add O/H 1)) (PROGN (add OTHER 1) (add O/O 1)))) ((Fixed Declined Obsolete Incomplete Superseded) (add FIXED 1) (SELECTQ (CADDR AR) (Absolutely (add ABS 1) (add F/A 1)) (Hopefully (add HOPE 1) (add F/H 1)) (PROGN (add OTHER 1) (add F/O 1)))) (SELECTQ (CADDR AR) (Absolutely (add ABS 1)) (Hopefully (add HOPE 1)) (add OTHER 1))) finally (PRINTOUT T "      NEW     FIXED" T "ABS  " O/A "     " F/A T "HOPE " O/H "     " F/H T "OTHR " O/O "     " F/O T T)))
)

(COUNT-BY-WEEK
(LAMBDA NIL (* ; "Edited 23-Apr-87 14:17 by jds") (LET ((SUBMITS BETASUBMITS) (FIXES BETAFIXES) (WASFIXED (SORT SUBMITTEDFIXED)) SUB FIX SUBFIX SD) (for START from (IDATE "2-FEB-87 00:00:00") by 604800 as END from (IDATE "9-FEB-87 00:00:00") by 604800 while (OR SUBMITS FIXES) do (PRINTOUT T T T "Week of " (GDATE START) " - " (GDATE END) T T) (SETQ SUB (bind AR while (AND SUBMITS (IGEQ END (IDATE (CONCAT (CAR (NTH (CADR (SETQ AR (CAR SUBMITS))) (IDIFFERENCE (LENGTH (CADR AR)) 1))) " 00:00")))) collect (CAR (pop SUBMITS)))) (SETQ FIX (bind AR while (AND FIXES (IGEQ END (IDATE (CONCAT (CADR (CADDR (SETQ AR (CAR FIXES)))) " 00:00")))) collect (CADR (pop FIXES)))) (SETQ SUBFIX (for AR in SUB while WASFIXED when (COND ((NULL WASFIXED) NIL) ((IEQP AR (CAR WASFIXED)) (pop WASFIXED) T) ((ILESSP AR (CAR WASFIXED)) NIL) (T (HELP "Mismatch -- a sub-as-fixed ar never got submitted?"))) collect AR)) (PRINTOUT T "      Submitted: " |.I3| (LENGTH SUB) ",	") (BREAKOUT-ARS-BY-TYPE SUB) (PRINTOUT T "Submitted&Fixed: " |.I3| (LENGTH SUBFIX) ",	") (BREAKOUT-ARS-BY-TYPE SUBFIX) (PRINTOUT T "    Newly Fixed: " |.I3| (LENGTH FIX) ",	") (BREAKOUT-ARS-BY-TYPE FIX) (PRINTOUT T T))))
)

(BREAKOUT-ARS-BY-TYPE
(LAMBDA (ARLIST) (* ; "Edited 23-Feb-88 18:26 by bvm") (bind (OTHER _ 0) (ABS _ 0) (HOPE _ 0) (FEAT _ 0) (PERF _ 0) (DOCABS _ 0) (DOCHOPE _ 0) (DOCOTHER _ 0) (DUNNO _ 0) AR for AR# in ARLIST do (SETQ AR (ASSOC AR# BETAINFO)) (COND ((NULL AR) (add DUNNO 1)) ((MEMBER (QUOTE Documentation) AR) (SELECTQ (CADDR AR) (Absolutely (add DOCABS 1)) (Hopefully (add DOCHOPE 1)) (add DOCOTHER 1))) ((MEMBER (QUOTE Feature) AR) (add FEAT 1)) ((MEMBER (QUOTE Performance) AR) (add PERF 1)) (T (SELECTQ (CADDR AR) (Absolutely (add ABS 1)) (Hopefully (add HOPE 1)) (add OTHER 1)))) finally (PRINTOUT T "BUGS:  Abs: " |.I3| ABS "   Hope: " |.I3| HOPE "   Other: " |.I3| OTHER "  || DOC: Abs: " |.I3| DOCABS "   Hope: " |.I3| DOCHOPE "   Other: " |.I3| DOCOTHER "  || Features: " |.I3| FEAT "   Perf: " PERF (COND ((ZEROP DUNNO) "") (T (CONCAT "   Can't Tell: " DUNNO))) T)))
)
)



(* ;; "Functions for making a summary of all feature requests or hopefully-type ARs.")

(DEFINEQ

(FEATURE.SUMMARY
(LAMBDA (INDEX-WINDOW SUMMARY.LOCAL.DIR) (* ; "Edited 24-Feb-88 20:07 by bvm") (* ;;; "Make a summary of all extant feature-request ARs:") (AR.QUERY.PRINT.AND.IP.FILE INDEX-WINDOW (QUOTE (AND (OR (Status%: IS Open) (Status%: IS New)) (|Problem Type:| IS Feature) (NOT (OR (System%: IS LOOPS) (System%: IS PCE) (System%: IS PROLOG) (System%: IS BusMaster) (Subsystem%: IS DEI))))) (QUOTE (System%: Subsystem%: Priority%:)) (CONCAT (OR SUMMARY.LOCAL.DIR (QUOTE {DSK6})) "FeatureSummary")))
)

(HOPE.SUMMARY
(LAMBDA (INDEX-WINDOW SUMMARY.LOCAL.DIR FIELDS-TO-PRINT) (* ; "Edited 24-Feb-88 20:15 by bvm") (* ;;; "Make a summary of all Lyric Absolutely ARs:") (AR.QUERY.PRINT.AND.IP.FILE INDEX-WINDOW (QUOTE (AND (OR (Status%: IS Open) (Status%: IS New)) (Priority%: IS Hopefully) (NOT (OR (|Problem Type:| IS Feature) (|Problem Type:| IS Documentation) (System%: IS LOOPS) (System%: IS PCE) (System%: IS PROLOG) (System%: IS BusMaster) (Subsystem%: IS DEI))))) (QUOTE (System%: Subsystem%: Priority%:)) (CONCAT (OR SUMMARY.LOCAL.DIR (QUOTE {DSK6})) "HopeSummary") NIL FIELDS-TO-PRINT))
)

(OPEN.SUMMARY
  [LAMBDA (SUMMARY.LOCAL.DIR)                            (* ; "Edited  3-Feb-89 10:29 by jds")

(* ;;; "Make a summary of all ARs that are Open. ")

    (AR.QUERY.PRINT.AND.IP.FILE NIL '(OR (Status%: IS New)
                                         (Status%: IS Open)
                                         (Status%: IS Open/Unreleased)
                                         (Status%: IS Incomplete)
                                         (Status%: IS Internal)
                                         (Status%: IS Wish))
           '(System%: Subsystem%: Priority%:)
           "OpenSummary"
           (OR SUMMARY.LOCAL.DIR '{DSK}])

(FIXED.SUMMARY
(LAMBDA (SUMMARY.LOCAL.DIR) (* ; "Edited 24-Feb-88 20:28 by bvm") (* ;;; "Make a summary of all ARs that are FIXED ") (LET ((LOCAL.AR.INDEX.NAME (AND SUMMARY.LOCAL.DIR (CONCAT SUMMARY.LOCAL.DIR (QUOTE AR.INDEX))))) (* ;; "Copy the AR index to local disk if it's not there already.") (COND (LOCAL.AR.INDEX.NAME (COPYFILES AR.INDEX.DEFAULT.FILE.NAME LOCAL.AR.INDEX.NAME (QUOTE >A)))) (AR.QUERY.PRINT.AND.IP.FILE LOCAL.AR.INDEX.NAME (QUOTE (AND (Status%: IS Fixed))) NIL (PACKFILENAME.STRING (QUOTE NAME) "FixedSummary" (QUOTE DIRECTORY) SUMMARY.LOCAL.DIR) NIL (QUOTE ((Number%: 5) (Subject%: 60))))))
)
)



(* ;; 
"Function for making lyric relevant summaries of Absolutely bugs, and a listing of all open ARs.")

(DEFINEQ

(ABSOLUTELY.SUMMARIES
(LAMBDA (SUMMARY.LOCAL.DIR INDIVIDUAL-SUMMARIES? INDEX-ALREADY-COPIED? THESE-NAMES-ONLY) (* ; "Edited 24-Feb-88 20:25 by bvm") (* ;;; "Create a summary for each developer, listing the ABSOLUTELY ARs in that person's name, and an %"AllBugs%" summary of Open/New ARs.") (* ;; "If INDIVIDUAL-SUMMARIES? (or THESE-NAMES-ONLY) then produce a summary for each developer listing his/her absolutelies.  If THESE-NAMES-ONLY, then only do it for those names.") (LET ((LOCAL.AR.INDEX.NAME (AND SUMMARY.LOCAL.DIR (CONCAT SUMMARY.LOCAL.DIR (QUOTE AR.INDEX)))) INDEX.WINDOW) (COND ((AND LOCAL.AR.INDEX.NAME (NOT INDEX-ALREADY-COPIED?)) (printout T "copying old AR index to " LOCAL.AR.INDEX.NAME "...") (COPYFILES AR.INDEX.DEFAULT.FILE.NAME LOCAL.AR.INDEX.NAME (QUOTE >A)) (printout T "done" T))) (SETQ INDEX.WINDOW (CREATEW (QUOTE (0 0 200 100)))) (AR.QFORM.CREATE LOCAL.AR.INDEX.NAME INDEX.WINDOW T) (* ;; "Make the summary of all open/new ARs, for cleanup purposes:") (COND ((NOT THESE-NAMES-ONLY) (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW (QUOTE (AND (OR (Status%: IS Open) (Status%: IS New)))) (QUOTE (System%: Subsystem%: Status%:)) (PACKFILENAME.STRING (QUOTE NAME) "AllBugsSummary" (QUOTE DIRECTORY) SUMMARY.LOCAL.DIR)) (* ;; "Make a summary of all Lyric Absolutely ARs:") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW (QUOTE (AND (OR (Status%: IS Open) (Status%: IS New)) (Priority%: IS Absolutely) (NOT (OR (|Problem Type:| IS Feature) (|Problem Type:| IS Documentation) (System%: IS LOOPS) (System%: IS PCE) (System%: IS PROLOG) (System%: IS BusMaster) (Subsystem%: IS DEI))))) (QUOTE (System%: Subsystem%: Status%:)) (PACKFILENAME.STRING (QUOTE NAME) "LyricAbsSummary" (QUOTE DIRECTORY) SUMMARY.LOCAL.DIR)))) (* ;; "Make summaries for everyone:") (COND ((OR THESE-NAMES-ONLY INDIVIDUAL-SUMMARIES?) (for HACKER.NAME in (OR THESE-NAMES-ONLY AR.ABSOLUTELY.HACKER.NAMES) do (* ;; "Query on non-feature, non-doc absolutelies for this guy") (AR.QUERY.PRINT.AND.IP.FILE INDEX.WINDOW (BQUOTE (AND (OR (Status%: IS Open) (Status%: IS New)) (Priority%: IS Absolutely) (Attn%: HAS (\, (SUBSTRING HACKER.NAME 1 (IMIN 4 (NCHARS HACKER.NAME))))) (NOT (OR (|Problem Type:| IS Feature) (|Problem Type:| IS Documentation))))) AR.CLEANUP.SORT.ORDER (PACKFILENAME.STRING (QUOTE NAME) (CONCAT HACKER.NAME "Summary") (QUOTE DIRECTORY) SUMMARY.LOCAL.DIR)) (* ;; "Print the summary, but don't copy it anywhere (leave it on the local summary dir)")))) (* ;; "Close the query window we used for this process.") (CLOSEW INDEX.WINDOW)))
)

(ABS.SUMMARY
(LAMBDA (INDEX-WINDOW SUMMARY.LOCAL.DIR) (* ; "Edited 24-Feb-88 20:27 by bvm") (* ;;; "Make a summary of all Lyric Absolutely ARs:") (AR.QUERY.PRINT.AND.IP.FILE NIL (QUOTE (AND (OR (Status%: IS Open) (Status%: IS New)) (Priority%: IS Absolutely) (In/By%: HAS Motown) (NOT (OR (System%: IS LOOPS) (System%: IS PCE) (System%: IS PROLOG) (System%: IS BusMaster) (Subsystem%: IS DEI))))) (QUOTE (System%: Subsystem%: Status%:)) (CONCAT (OR SUMMARY.LOCAL.DIR (QUOTE {DSK6})) "LyricAbsSummary")))
)
)

(RPAQ? AR.ABSOLUTELY.HACKER.NAMES '(Bane Biggs Burton Charnley Cude Daniels Fischer Kelley Murage
                                             Pavel Pedersen Shih Snow Sye SCPeters RMRichardson 
                                             Sybalsky vanMelle Woz))



(* ; 
"Function for caching the ar index locally, and causing all later queries to use the local cache.")


(RPAQ? LOCAL-CACHE-ORIGINAL-AR-INDEX-NAME AR.INDEX.DEFAULT.FILE.NAME)
(DEFINEQ

(CACHE-ARINDEX
(LAMBDA (LOCALNAME) (* ; "Edited  1-Jul-87 10:39 by jds") (* ;; "Copy the ar index to a LOCALNAME cache spot, and redirect the local pointers so queries operate there.") (* ;; "CAUTION:  This will cause you not to see new versions of the index, and you'll lose the cache if you reload AREDIT et al.") (COPYFILES LOCAL-CACHE-ORIGINAL-AR-INDEX-NAME LOCALNAME) (* ; "Copy the file") (SETQ AR.INDEX.DEFAULT.FILE.NAME LOCALNAME))
)
)



(* ;; 
"Fns for moving closed/obsolete/etc ar files from main directory to the <ClosedLispARs> directory.")

(DEFINEQ

(MAKE-AR-FILENAME
  [LAMBDA (DIR NUMBER)                                   (* ; "Edited  7-Feb-90 17:12 by jds")
    (PACKFILENAME.STRING 'DIRECTORY DIR 'BODY (CL:FORMAT NIL "~5,'0D.AR" NUMBER])

(MOVE-CLOSED-ARS
  [LAMBDA (NUMBERS)
    (for AR in NUMBERS do (RENAMEFILE (MAKE-AR-FILENAME "{ERINYES}<LISPARS>" AR)
                                             (MAKE-AR-FILENAME "{ERINYES}<CLOSEDLISPARS>" AR))
                                     (PRINTOUT T "Moved AR file for AR " AR T])
)



(* ;; "These names superseded by other functions on this file or on AREDIT")

(DEFINEQ

(GET.NUMS.FROM.QUERY
(LAMBDA NIL (* ; "Edited 18-Feb-88 12:43 by bvm") (* ;; "Gather the AR numbers listed in a query window, and return a list of them.  Useful for getting AR numbers into Lisp for further processing.") (AR.NUMS.FROM.QUERY))
)

(LANDSCAPE.QUERY.WINDOW
(LAMBDA (LOCALTXTFILE LOCALIPFILE) (* ; "Edited 23-Feb-88 17:51 by bvm") (* ;; "This function takes the names of two files.  LOCALTXTFILE is the file which has been created by PRINTing to a Print File in a query window.  LOCALIPFILE is the file that you want to be created with landscaping.") (AR.IP.FILE LOCALTXTFILE LOCALIPFILE))
)

(HARDCOPY.ARS
(LAMBDA (NUMS) (* ; "Edited 23-Feb-88 18:27 by bvm") (AR.HARDCOPY NUMS)))
)



(* ;; 
"Function for querying, and getting a list of the selected AR numbers.  In effect, this is a programmatic interface to AR.QUERY."
)

(DEFINEQ

(GET-SELECTED-AR-NUMBERS
  [LAMBDA (QUERY-SPEC SUMMARY.LOCAL.DIR)                 (* ; "Edited 17-Jan-89 18:20 by jds")

(* ;;; "Return a list of all the AR numbers matching QUERY-SPEC.  If SUMMARY.LOCAL.DIR, then cache the AR.INDEX file there for this operation. ")

    (LET ((LOCAL.AR.INDEX.NAME (COND
                                  (SUMMARY.LOCAL.DIR (PACK* SUMMARY.LOCAL.DIR 'AR.INDEX))
                                  (T NIL)))
          INDEX.WINDOW SELECTED-ARS)

         (* ;; "Copy the AR index to local disk if it's not there already.")

         [COND
            (LOCAL.AR.INDEX.NAME (COPYFILES AR.INDEX.DEFAULT.FILE.NAME LOCAL.AR.INDEX.NAME
                                        '>A]

         (* ;; "Open the query window")

         (SETQ INDEX.WINDOW (CREATEW (CREATEREGION 0 0 200 100)))
         (AR.QFORM.GROUP.CREATE LOCAL.AR.INDEX.NAME INDEX.WINDOW T)

         (* ;; "Grab the ARs & print the summary:")

         (AR.QUERY INDEX.WINDOW QUERY-SPEC)
         (SETQ SELECTED-ARS (AR.NUMS.FROM.QUERY INDEX.WINDOW))
         (CLOSEW INDEX.WINDOW)
         SELECTED-ARS])
)



(* ; "Functions for making release notes & the like:")




(* ;; 
"NOTES takes a list of items (AR# subj-string relnote-string) and prints them one to a line, with tab after AR# &  new-line (not new-para) before relnote into a TEdit."
)

(DEFINEQ

(NOTES
  [LAMBDA (ARS TITLE)                                    (* ; "Edited 17-Jan-89 18:28 by jds")

    (* ;; "Given a list of items like (AR# Subject-string Rel-Note-String), print them into a TEdit document one to a paragraph, with a newline after the subject.  Intended for the collation of release notes.")

    (LET ((TS (OPENTEXTSTREAM "")))
         (TEDIT.SETSEL TS 1 0 'RIGHT)
         (AND TITLE (TEDIT.INSERT TS (CONCAT TITLE "

")))
         (for AR-INFO in ARS do (TEDIT.INSERT TS (CONCAT (MKSTRING (CAR AR-INFO))
                                                                    "	"
                                                                    (CADR AR-INFO)
                                                                    (CHARACTER (CHARCODE "##^M"))
                                                                    (CADDR AR-INFO)
                                                                    "
")))
         (TEDIT TS])
)
(DEFINEQ

(KNOWN-BUG-LIST
  [LAMBDA (SUMMARY.LOCAL.DIR)                            (* ; "Edited 17-Jan-89 18:33 by jds")
    (LET (ARS NOTES)
         (SETQ ARS (GET-SELECTED-AR-NUMBERS '[AND (OR (Status%: IS Open)
                                                          (Status%: IS Open/Unreleased)
                                                          (Status%: IS New))
                                                      (Priority%: IS Hopefully)
                                                      (NOT (OR (|Problem Type:| IS Feature)
                                                               (|Problem Type:| IS Documentation)
                                                               (System%: IS LOOPS)
                                                               (System%: IS PCE)
                                                               (System%: IS PROLOG)
                                                               (System%: IS BusMaster)
                                                               (Subsystem%: IS DEI]
                          SUMMARY.LOCAL.DIR))
         (SETQ ARS (AR.GET.PLIST ARS '(Subject%: |Release Note:|)
                          T))
         (SETQ NOTES (NOTES ARS (CONCAT "Known Bugs List as of " (DATE])

(FIXED-BUG-LIST
  [LAMBDA (SUMMARY.LOCAL.DIR)                            (* ; "Edited 17-Jan-89 18:32 by jds")
    (LET (ARS NOTES)
         (SETQ ARS (GET-SELECTED-AR-NUMBERS '[AND (Status%: IS Fixed)
                                                      (NOT (OR (System%: IS LOOPS)
                                                               (System%: IS PCE)
                                                               (System%: IS PROLOG)
                                                               (System%: IS BusMaster)
                                                               (Subsystem%: IS DEI]
                          SUMMARY.LOCAL.DIR))
         (SETQ ARS (AR.GET.PLIST ARS '(Subject%: |Release Note:|)
                          T))
         (SETQ NOTES (NOTES ARS (CONCAT "Fixed Bugs List as of " (DATE])
)
(PUTPROPS ARHACK COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1991))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4398 5339 (AR.GET.PLIST 4408 . 5337)) (5394 5961 (NAB.TEST.CASES 5404 . 5959)) (6015 
6575 (LAST-CHANGED-BEFORE 6025 . 6573)) (6629 8702 (AR.GET.SUBMITS.FROM.TDS 6639 . 6919) (
AR.GET.FIXES.FROM.TDS 6921 . 7303) (AR.GET.ARS.FROM.TDS 7305 . 8348) (COLLECT-FIXES 8350 . 8520) (
COLLECT-SUBMISSIONS 8522 . 8700)) (8841 10805 (FIX.MANY.ARS 8851 . 10478) (FIX.NO.RELEASE.NOTE 10480
 . 10803)) (11014 11828 (CHANGE.MANY.ARS 11024 . 11826)) (11910 14289 (CLOSE.MANY.ARS 11920 . 12811) (
OBSOLETE.MANY.ARS 12813 . 14287)) (14345 20665 (LIST.NUM.STATUS.PRIORITY 14355 . 14711) (COUNT-ARS 
14713 . 18578) (COUNT-BY-WEEK 18580 . 19775) (BREAKOUT-ARS-BY-TYPE 19777 . 20663)) (20761 23175 (
FEATURE.SUMMARY 20771 . 21281) (HOPE.SUMMARY 21283 . 21878) (OPEN.SUMMARY 21880 . 22552) (
FIXED.SUMMARY 22554 . 23173)) (23290 26341 (ABSOLUTELY.SUMMARIES 23300 . 25828) (ABS.SUMMARY 25830 . 
26339)) (26800 27257 (CACHE-ARINDEX 26810 . 27255)) (27374 27910 (MAKE-AR-FILENAME 27384 . 27590) (
MOVE-CLOSED-ARS 27592 . 27908)) (27996 28711 (GET.NUMS.FROM.QUERY 28006 . 28253) (
LANDSCAPE.QUERY.WINDOW 28255 . 28616) (HARDCOPY.ARS 28618 . 28709)) (28859 29996 (
GET-SELECTED-AR-NUMBERS 28869 . 29994)) (30246 31248 (NOTES 30256 . 31246)) (31249 33419 (
KNOWN-BUG-LIST 31259 . 32556) (FIXED-BUG-LIST 32558 . 33417)))))
STOP
\ No newline at end of file
diff --git a/internal/library/ARINDEX b/internal/library/ARINDEX
new file mode 100644
index 00000000..58ffad36
--- /dev/null
+++ b/internal/library/ARINDEX
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Apr-92 18:07:47" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>ARINDEX.;4| 19157  

      changes to%:  (VARS ARINDEXCOMS)

      previous date%: "15-Jun-90 10:59:57" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>ARINDEX.;3|)


(* ; "
Copyright (c) 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT ARINDEXCOMS)

(RPAQQ ARINDEXCOMS
       (
        (* ;; "Creating and updating the index.  Separate file because AREDIT doesn't need this")

        (FNS AR.GATHER.NEW.AR.DATA AR.INDEX.CREATE AR.GET.ENUMERATED.FIELD.KEYS 
             AR.INDEX.FIND.ENTRY.PTR AR.INDEX.REWRITE.ENTRY.DATA AR.INDEX.REWRITE.FIELD.DATA 
             AR.QFORM.FN.PRINT.INDEX AR.INDEX.PRINT AR.QFORM.FN.UPDATE AR.INDEX.UPDATE)
        (FNS AR.GET.FIELD.VAL.LENGTH AR.GET.FIELD.VAL.PTR AR.GET.FIELD.VAL.SHAPE AR.GET.ENTRY.NUM)
        [INITVARS (AR.INDEX.DEFAULT.FIELDS '(Subject%: Source%: Date%: Submitter%: |Assigned To:| 
                                                   Attn%: Status%: In/By%: |Problem Type:| Impact%: 
                                                   Difficulty%: Frequency%: Priority%: System%: 
                                                   Subsystem%: Machine%: Disk%: |Lisp Version:| 
                                                   |Source Files:| |Microcode Version:| 
                                                   |Memory Size:| |File Server:| 
                                                   |Server Software Version:| Edit-By%: Edit-Date%:]
        (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                                ARQUERY)
               (GLOBALVARS AR.INDEX.DEFAULT.FIELDS)
               (FUNCTIONS AR.ENTRY.PTR.TO.KEY.VAL.PTR ARSPECPUT))))



(* ;; "Creating and updating the index.  Separate file because AREDIT doesn't need this")

(DEFINEQ

(AR.GATHER.NEW.AR.DATA
(LAMBDA (FORMWINDOW AR.NUM.LIST AR.SCRATCH.FILE) (* ; "Edited 21-Jul-88 15:08 by bvm") (* ;;; "AR.NUM.DATA should be a sorted list of AR numbers.  AR.GATHER.NEW.AR.DATA returns a list with elements of the form (<arnum> <arptr>  . <ar.scratch.assoc>)") (LET ((AR.NUM.DATA (for AR.NUM in AR.NUM.LIST bind START collect (BLOCK) (SETQ START (GETFILEPTR AR.SCRATCH.FILE)) (LIST* AR.NUM NIL (CL:MULTIPLE-VALUE-BIND (INDEX.INFO CONDITION) (AR.FETCH.AND.PARSE.AR AR.NUM AR.SCRATCH.FILE AR.INDEX.FIELD.LIST T) (if CONDITION then (AR.PROMPT.PRINT FORMWINDOW T "Can't get AR info for AR # " AR.NUM) (SETFILEPTR AR.SCRATCH.FILE START) (* ; "Reset scratch pointer in case we started loading it") (QUOTE DELETE) else (AR.PROMPT.PRINT FORMWINDOW T "analyzed AR # " AR.NUM) INDEX.INFO)))))) (for X in AR.NUM.DATA do (* ; "Fill in the entry pointers") (RPLACA (CDR X) (AR.INDEX.FIND.ENTRY.PTR (CAR X)))) AR.NUM.DATA))
)

(AR.INDEX.CREATE
(LAMBDA (FILENAME FIELD.LIST FORM.SPECS) (* ; "Edited 21-Jul-88 14:36 by bvm") (* ;; "Create an empty AR index file.") (OR FIELD.LIST (SETQ FIELD.LIST AR.INDEX.DEFAULT.FIELDS)) (OR FORM.SPECS (SETQ FORM.SPECS AR.FORM.SPECS)) (LET ((FILE (OPENSTREAM FILENAME (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE BINARY))))) (INDEX.DATA (create AR.INDEX.DATA AR.INDEX.FILE _ NIL AR.INDEX.ENTRY.BEGIN.PTR _ 0 AR.INDEX.ENTRY.END.PTR _ 0 AR.INDEX.FIELD.LIST _ FIELD.LIST)) (FIELD.SPECS (for X in FIELD.LIST collect (LIST X (QUOTE FIELD.BEGIN.PTR) 0 (QUOTE FIELD.END.PTR) 0))) (FIELD.PTR.OFFSET 4)) (for FIELD in FIELD.LIST bind ENUMERATED.FIELD.KEYS do (if (SETQ ENUMERATED.FIELD.KEYS (AR.GET.ENUMERATED.FIELD.KEYS FORM.SPECS FIELD)) then (ARSPECPUT FIELD.SPECS FIELD (QUOTE ENUMERATED.FIELD.KEYLIST) (for FIELD.KEY in ENUMERATED.FIELD.KEYS as NUM from 1 join (LIST FIELD.KEY NUM))) else (ARSPECPUT FIELD.SPECS FIELD (QUOTE FIELD.OFFSET) FIELD.PTR.OFFSET) (add FIELD.PTR.OFFSET 4))) (replace (AR.INDEX.DATA AR.INDEX.FIELD.SPECS) of INDEX.DATA with FIELD.SPECS) (replace (AR.INDEX.DATA AR.INDEX.ENTRY.SIZE) of INDEX.DATA with FIELD.PTR.OFFSET) (SETFILEPTR FILE 0) (PRINT INDEX.DATA FILE FILERDTBL) (* ; "set DIR.FORMAT.PTR to 0") (\DWOUT FILE 0) (CLOSEF FILE)))
)

(AR.GET.ENUMERATED.FIELD.KEYS
(LAMBDA (FORM.SPECS FIELD) (* ; "Edited 14-Feb-88 00:10 by bvm") (* ;; "Return all the valid keys for this field") (LET ((FIELD.SPEC (CDR (ASSOC FIELD FORM.SPECS)))) (SELECTQ (LISTGET FIELD.SPEC (QUOTE FIELDTYPE)) (MENU (LISTGET FIELD.SPEC (QUOTE MENULIST))) (SUBMENU (CL:REMOVE-DUPLICATES (for X in (CDR (LISTGET FIELD.SPEC (QUOTE SUBMENULIST))) by (CDDR X) join (APPEND X)))) NIL)))
)

(AR.INDEX.FIND.ENTRY.PTR
(LAMBDA (NUM LOW.HINT HIGH.HINT) (* edited%: "21-Aug-84 14:37") (PROG ((LOW (if LOW.HINT else AR.INDEX.ENTRY.BEGIN.PTR)) (HIGH (if HIGH.HINT else AR.INDEX.ENTRY.END.PTR)) LOW.NUM HIGH.NUM TEST TEST.NUM) (SETQ LOW.NUM (AR.GET.ENTRY.NUM LOW)) (SETQ HIGH.NUM (AR.GET.ENTRY.NUM HIGH)) (if (IGREATERP NUM HIGH.NUM) then (SHOULDNT "Entry pointer higher than higher bound")) loop (if (EQP NUM LOW.NUM) then (RETURN (CONS LOW T))) (if (EQP NUM HIGH.NUM) then (RETURN (CONS HIGH T))) (SETQ TEST (IPLUS LOW (ITIMES (IQUOTIENT (IQUOTIENT (IDIFFERENCE HIGH LOW) 2) AR.INDEX.ENTRY.SIZE) AR.INDEX.ENTRY.SIZE))) (if (EQP TEST LOW) then (RETURN (CONS HIGH NIL))) (SETQ TEST.NUM (AR.GET.ENTRY.NUM TEST)) (if (IGEQ NUM TEST.NUM) then (SETQ LOW TEST) (SETQ LOW.NUM TEST.NUM) else (SETQ HIGH TEST) (SETQ HIGH.NUM TEST.NUM)) (GO loop)))
)

(AR.INDEX.REWRITE.ENTRY.DATA
(LAMBDA (NEW.FILE NUM.DATA.LIST) (* edited%: "16-Jul-84 15:55") (PROG ((ENTRY.PTR AR.INDEX.ENTRY.BEGIN.PTR) (FIELDS.WITH.OFFSETS (for FIELD.NAME in AR.INDEX.FIELD.LIST when (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.OFFSET)) collect FIELD.NAME)) FIELD.INCREMENT.LIST) (SETQ FIELD.INCREMENT.LIST (for X in FIELDS.WITH.OFFSETS collect 0)) (until (AND (NULL NUM.DATA.LIST) (IGEQ ENTRY.PTR AR.INDEX.ENTRY.END.PTR)) bind NUM.DATA NEXT.HIGHER.ENTRY.PTR REPLACE.FLG do (SETQ NUM.DATA (CAR NUM.DATA.LIST)) (SETQ NEXT.HIGHER.ENTRY.PTR (CAR (CADR NUM.DATA))) (SETQ REPLACE.FLG (CDR (CADR NUM.DATA))) (if (OR (NULL NUM.DATA.LIST) (IGREATERP NEXT.HIGHER.ENTRY.PTR ENTRY.PTR)) then (* ;; "copy an existing AR entry, rather than create a new one") (SETFILEPTR AR.INDEX.FILE ENTRY.PTR) (* ; "copy AR number to new entry") (\DWOUT NEW.FILE (\DWIN AR.INDEX.FILE)) (* ; "copy ptrs to various fields, adding on current increments") (for X in FIELD.INCREMENT.LIST do (\DWOUT NEW.FILE (IPLUS X (\DWIN AR.INDEX.FILE)))) (SETQ ENTRY.PTR (GETFILEPTR AR.INDEX.FILE)) else (* ;; "add a new AR entry from NUM.DATA.LIST") (if (NOT (EQ (CDDR NUM.DATA) (QUOTE DELETE))) then (* ; "put out new number") (\DWOUT NEW.FILE (CAR NUM.DATA)) (* ; "put out field ptrs for next higher field") (for FIELD.NAME in FIELDS.WITH.OFFSETS as X in FIELD.INCREMENT.LIST as FIELD.OFFSET from 4 by 4 bind FIELD.BEGIN.PTR do (SETQ FIELD.BEGIN.PTR (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.BEGIN.PTR))) (\DWOUT NEW.FILE (IPLUS X (IDIFFERENCE (AR.GET.FIELD.VAL.PTR NEXT.HIGHER.ENTRY.PTR FIELD.NAME FIELD.OFFSET FIELD.BEGIN.PTR) FIELD.BEGIN.PTR)))) (* ; "now, add field lengths to FIELD.INCREMENT.LIST") (for FIELD.NAME in FIELDS.WITH.OFFSETS as INC.LIST on FIELD.INCREMENT.LIST bind AR.FIELD.DATA do (SETQ AR.FIELD.DATA (ASSOC FIELD.NAME (CDDR NUM.DATA))) (if AR.FIELD.DATA then (RPLACA INC.LIST (IPLUS (CAR INC.LIST) (CADDR AR.FIELD.DATA)))))) (* ;; "if we are replacing an old AR, we must SUBTRACT the field lengths of the old AR from FIELD.INCREMENT.LIST") (if REPLACE.FLG then (for INC.LIST on FIELD.INCREMENT.LIST as LENGTH.TO.BE.DELETED in (for FIELD.NAME in FIELDS.WITH.OFFSETS collect (AR.GET.FIELD.VAL.LENGTH NEXT.HIGHER.ENTRY.PTR FIELD.NAME)) do (RPLACA INC.LIST (IDIFFERENCE (CAR INC.LIST) LENGTH.TO.BE.DELETED))) (SETQ ENTRY.PTR (IPLUS ENTRY.PTR AR.INDEX.ENTRY.SIZE))) (SETQ NUM.DATA.LIST (CDR NUM.DATA.LIST))))))
)

(AR.INDEX.REWRITE.FIELD.DATA
(LAMBDA (NEWFILE SCRATCHFILE FIELD.NAME NUM.DATA.LIST) (* ; "Edited 21-Jul-88 15:04 by bvm") (PROG ((FIELD.KEYLIST (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE ENUMERATED.FIELD.KEYLIST))) (FIELD.OFFSET (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.OFFSET))) (FIELD.DATA.BEGIN.PTR (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.BEGIN.PTR))) (FIELD.DATA.END.PTR (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.END.PTR))) DATA.PTR) (if (NOT (OR FIELD.KEYLIST FIELD.OFFSET)) then (ERROR "Field doesn't have keylist or offset" FIELD.NAME)) (SETQ DATA.PTR FIELD.DATA.BEGIN.PTR) (for NUM.DATA in NUM.DATA.LIST bind NEXT.HIGHER.ENTRY.PTR REPLACE.FLG NEXT.HIGHER.FIELD.VAL.PTR NUM.DATA.FOR.FIELD SCRATCH.FIELD.LEN do (SETQ NEXT.HIGHER.ENTRY.PTR (CAR (CADR NUM.DATA))) (SETQ REPLACE.FLG (CDR (CADR NUM.DATA))) (SETQ NEXT.HIGHER.FIELD.VAL.PTR (if FIELD.OFFSET then (AR.GET.FIELD.VAL.PTR NEXT.HIGHER.ENTRY.PTR FIELD.NAME FIELD.OFFSET FIELD.DATA.BEGIN.PTR FIELD.DATA.END.PTR) else (AR.ENTRY.PTR.TO.KEY.VAL.PTR NEXT.HIGHER.ENTRY.PTR FIELD.DATA.BEGIN.PTR))) (if (< DATA.PTR NEXT.HIGHER.FIELD.VAL.PTR) then (COPYBYTES AR.INDEX.FILE NEWFILE DATA.PTR NEXT.HIGHER.FIELD.VAL.PTR)) (if (NOT (EQ (CDDR NUM.DATA) (QUOTE DELETE))) then (SETQ NUM.DATA.FOR.FIELD (ASSOC FIELD.NAME (CDDR NUM.DATA))) (* ; "(field start length)") (if NUM.DATA.FOR.FIELD then (SETQ SCRATCH.FIELD.LEN (CADDR NUM.DATA.FOR.FIELD)) (SETFILEPTR SCRATCHFILE (CADR NUM.DATA.FOR.FIELD)) (if FIELD.OFFSET then (* ; "String field") (if (> SCRATCH.FIELD.LEN 0) then (COPYBYTES SCRATCHFILE NEWFILE SCRATCH.FIELD.LEN)) else (* ; "Enumerated field") (BOUT NEWFILE (OR (LISTGET FIELD.KEYLIST (PACKC (AR.READ.BYTES SCRATCHFILE SCRATCH.FIELD.LEN))) 0))) elseif (NOT FIELD.OFFSET) then (* ; "Empty enumerated field--all must be present (string fields can be sparse).") (BOUT NEWFILE 0))) (SETQ DATA.PTR (if REPLACE.FLG then (if FIELD.OFFSET then (AR.GET.FIELD.VAL.PTR (+ NEXT.HIGHER.ENTRY.PTR AR.INDEX.ENTRY.SIZE) FIELD.NAME FIELD.OFFSET FIELD.DATA.BEGIN.PTR FIELD.DATA.END.PTR) else (ADD1 NEXT.HIGHER.FIELD.VAL.PTR)) else NEXT.HIGHER.FIELD.VAL.PTR))) (if (< DATA.PTR FIELD.DATA.END.PTR) then (COPYBYTES AR.INDEX.FILE NEWFILE DATA.PTR FIELD.DATA.END.PTR))))
)

(AR.QFORM.FN.PRINT.INDEX
(LAMBDA (QFORMWINDOW) (* ; "Edited 16-Feb-88 22:36 by bvm") (WITH.AR.QUERY QFORMWINDOW (TTY.PROCESS (THIS.PROCESS)) (AR.INDEX.PRINT T) (AR.PROMPT "done" QFORMWINDOW)))
)

(AR.INDEX.PRINT
(LAMBDA (FILE PRINT.ENTRY.DATA.FLG) (* ; "Edited 15-Feb-88 18:37 by bvm") (LET ((*PRINT-BASE* 10)) (printout FILE "Total file size: " (GETEOFPTR AR.INDEX.FILE) " bytes" T T) (printout FILE "Total Field Space: " .TAB 20 AR.INDEX.ENTRY.BEGIN.PTR " bytes" T) (for FIELD.NAME in AR.INDEX.FIELD.LIST bind FIELD.BYTES do (SETQ FIELD.BYTES (- (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.END.PTR)) (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.BEGIN.PTR)))) (printout FILE FIELD.NAME .TAB 20 FIELD.BYTES T)) (printout FILE T "Total Entry Space: " (- AR.INDEX.ENTRY.END.PTR AR.INDEX.ENTRY.BEGIN.PTR) " bytes" T) (printout T (IQUOTIENT (- AR.INDEX.ENTRY.END.PTR AR.INDEX.ENTRY.BEGIN.PTR) AR.INDEX.ENTRY.SIZE) " entries of " AR.INDEX.ENTRY.SIZE " bytes" T) (if (EQ PRINT.ENTRY.DATA.FLG (QUOTE ALL)) then (for ENTRY.PTR from AR.INDEX.ENTRY.BEGIN.PTR by AR.INDEX.ENTRY.SIZE until (>= ENTRY.PTR AR.INDEX.ENTRY.END.PTR) do (printout FILE "Entry # " (PROGN (SETFILEPTR AR.INDEX.FILE ENTRY.PTR) (\DWIN AR.INDEX.FILE)) T) (for FIELD.NAME in AR.INDEX.FIELD.LIST bind VAL.DATA FIELD.KEYLIST VAL.NUM do (LET* ((FIELD.SPEC (CDR (ASSOC FIELD.NAME AR.INDEX.FIELD.SPECS))) (FIELD.BEGIN.PTR (LISTGET FIELD.SPEC (QUOTE FIELD.BEGIN.PTR))) (FIELD.OFFSET (LISTGET FIELD.SPEC (QUOTE FIELD.OFFSET)))) (if FIELD.OFFSET then (DESTRUCTURING-BIND (PTR . LEN) (AR.GET.FIELD.VAL.SHAPE ENTRY.PTR FIELD.OFFSET FIELD.BEGIN.PTR (LISTGET FIELD.SPEC (QUOTE FIELD.END.PTR))) (printout FILE FIELD.NAME " %"") (SETFILEPTR AR.INDEX.FILE PTR) (COPYBYTES AR.INDEX.FILE FILE LEN) (printout FILE "%"" T)) else (SETQ FIELD.KEYLIST (LISTGET FIELD.SPEC (QUOTE ENUMERATED.FIELD.KEYLIST))) (SETFILEPTR AR.INDEX.FILE (AR.ENTRY.PTR.TO.KEY.VAL.PTR ENTRY.PTR FIELD.BEGIN.PTR)) (printout FILE FIELD.NAME " %"") (SETQ VAL.NUM (BIN AR.INDEX.FILE)) (if (NEQ VAL.NUM 0) then (printout FILE (for X on FIELD.KEYLIST by (CDDR X) when (EQ VAL.NUM (CADR X)) do (RETURN (CAR X))))) (printout FILE "%"" T))))) elseif PRINT.ENTRY.DATA.FLG then (printout FILE "Contains entries: ") (for ENTRY.PTR from AR.INDEX.ENTRY.BEGIN.PTR by AR.INDEX.ENTRY.SIZE until (>= ENTRY.PTR AR.INDEX.ENTRY.END.PTR) do (printout FILE (PROGN (SETFILEPTR AR.INDEX.FILE ENTRY.PTR) (\DWIN AR.INDEX.FILE)) %,)) (TERPRI FILE))))
)

(AR.QFORM.FN.UPDATE
(LAMBDA (QFORMWINDOW) (* mjs " 8-Aug-84 15:18") (PROG ((ULIST (AR.GET.BUTTON.FIELD.AS.LIST QFORMWINDOW (QUOTE |Update List:|))) VAL) (SETQ VAL (AR.INDEX.UPDATE QFORMWINDOW ULIST)) (AR.PROMPT (LIST "Update done --- new file: " VAL) QFORMWINDOW)))
)

(AR.INDEX.UPDATE
(LAMBDA (FORMWINDOW AR.NUM.LIST) (* ; "Edited 21-Jul-88 15:07 by bvm") (* ;; "Update the AR index with changed ars listed in AR.NUM.LIST") (WITH.AR.QUERY FORMWINDOW (PROG (*UPPER-CASE-FILE-NAMES* AR.NUM.DATA AR.SCRATCH.FILE NEW.AR.INDEX.FILE NEW.AR.INDEX.DATA NEW.FIELD.SPECS NEW.AR.INDEX.DATA.PTR) (if (NOT (AND (LISTP AR.NUM.LIST) (EVERY AR.NUM.LIST (FUNCTION FIXP)))) then (AR.PROMPT.PRINT FORMWINDOW T "Bad AR number list") (RETURN)) (SETQ AR.NUM.LIST (SORT (CL:REMOVE-DUPLICATES AR.NUM.LIST))) (SETQ AR.SCRATCH.FILE (OPENSTREAM (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) (QUOTE AR.TEMP) (QUOTE BODY) (FULLNAME AR.INDEX.FILE)) (QUOTE BOTH) (QUOTE NEW) (QUOTE ((TYPE BINARY))))) (SETQ AR.NUM.DATA (AR.GATHER.NEW.AR.DATA FORMWINDOW AR.NUM.LIST AR.SCRATCH.FILE)) (* ; "Read the changed ar's data") (SETQ NEW.AR.INDEX.FILE (OPENSTREAM (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) (QUOTE ARINDEX.NEW) (QUOTE BODY) (FULLNAME AR.INDEX.FILE)) (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE BINARY))))) (* ; "Create a new index file") (SETQ NEW.AR.INDEX.DATA (create AR.INDEX.DATA AR.INDEX.FILE _ NIL AR.INDEX.FIELD.LIST _ AR.INDEX.FIELD.LIST AR.INDEX.ENTRY.SIZE _ AR.INDEX.ENTRY.SIZE)) (SETQ NEW.FIELD.SPECS (COPYALL AR.INDEX.FIELD.SPECS)) (for FIELD.NAME in AR.INDEX.FIELD.LIST do (ARSPECPUT NEW.FIELD.SPECS FIELD.NAME (QUOTE FIELD.BEGIN.PTR) (GETFILEPTR NEW.AR.INDEX.FILE)) (AR.INDEX.REWRITE.FIELD.DATA NEW.AR.INDEX.FILE AR.SCRATCH.FILE FIELD.NAME AR.NUM.DATA) (* ; "Write new or copy old data") (ARSPECPUT NEW.FIELD.SPECS FIELD.NAME (QUOTE FIELD.END.PTR) (GETFILEPTR NEW.AR.INDEX.FILE))) (DELFILE (CLOSEF AR.SCRATCH.FILE)) (replace (AR.INDEX.DATA AR.INDEX.FIELD.SPECS) of NEW.AR.INDEX.DATA with NEW.FIELD.SPECS) (replace (AR.INDEX.DATA AR.INDEX.ENTRY.BEGIN.PTR) of NEW.AR.INDEX.DATA with (GETFILEPTR NEW.AR.INDEX.FILE)) (AR.INDEX.REWRITE.ENTRY.DATA NEW.AR.INDEX.FILE AR.NUM.DATA) (replace (AR.INDEX.DATA AR.INDEX.ENTRY.END.PTR) of NEW.AR.INDEX.DATA with (GETFILEPTR NEW.AR.INDEX.FILE)) (SETQ NEW.AR.INDEX.DATA.PTR (GETFILEPTR NEW.AR.INDEX.FILE)) (PRINT NEW.AR.INDEX.DATA NEW.AR.INDEX.FILE FILERDTBL) (\DWOUT NEW.AR.INDEX.FILE NEW.AR.INDEX.DATA.PTR) (CLOSEF NEW.AR.INDEX.FILE) (RETURN (RENAMEFILE (FULLNAME NEW.AR.INDEX.FILE) (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) (FULLNAME AR.INDEX.FILE)))))))
)
)
(DEFINEQ

(AR.GET.FIELD.VAL.LENGTH
(LAMBDA (ENTRY.PTR FIELD.NAME FIELD.OFFSET FIELD.VAL.BEGIN.PTR FIELD.VAL.END.PTR) (* edited%: "13-Jul-84 14:45") (if (ILESSP ENTRY.PTR AR.INDEX.ENTRY.END.PTR) then (PROG ((NEXT.ENTRY.PTR (IPLUS ENTRY.PTR AR.INDEX.ENTRY.SIZE)) CURRENT.RELPTR NEXT.RELPTR) (if (NULL FIELD.OFFSET) then (SETQ FIELD.OFFSET (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.OFFSET)))) (SETFILEPTR AR.INDEX.FILE (IPLUS ENTRY.PTR FIELD.OFFSET)) (SETQ CURRENT.RELPTR (\DWIN AR.INDEX.FILE)) (SETQ NEXT.RELPTR (if (ILESSP NEXT.ENTRY.PTR AR.INDEX.ENTRY.END.PTR) then (SETFILEPTR AR.INDEX.FILE (IPLUS NEXT.ENTRY.PTR FIELD.OFFSET)) (\DWIN AR.INDEX.FILE) else (IDIFFERENCE (if FIELD.VAL.END.PTR else (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.END.PTR))) (if FIELD.VAL.BEGIN.PTR else (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.BEGIN.PTR)))))) (RETURN (IDIFFERENCE NEXT.RELPTR CURRENT.RELPTR))) else 0))
)

(AR.GET.FIELD.VAL.PTR
(LAMBDA (ENTRY.PTR FIELD.NAME FIELD.OFFSET FIELD.VAL.BEGIN.PTR FIELD.VAL.END.PTR) (* edited%: "13-Jul-84 15:41") (if (ILESSP ENTRY.PTR AR.INDEX.ENTRY.END.PTR) then (SETFILEPTR AR.INDEX.FILE (IPLUS ENTRY.PTR (if FIELD.OFFSET else (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.OFFSET))))) (IPLUS (if FIELD.VAL.BEGIN.PTR else (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.BEGIN.PTR))) (\DWIN AR.INDEX.FILE)) else (if FIELD.VAL.END.PTR else (ARSPECGET AR.INDEX.FIELD.SPECS FIELD.NAME (QUOTE FIELD.END.PTR)))))
)

(AR.GET.FIELD.VAL.SHAPE
(LAMBDA (ENTRY.PTR FIELD.OFFSET FIELD.BEGIN FIELD.END) (* ; "Edited 15-Feb-88 18:36 by bvm") (* ;; "Returns a pair (filepointer . length) describing the location and size of the text field described by the args.") (if (< ENTRY.PTR AR.INDEX.ENTRY.END.PTR) then (* ;; "Good entry value.  The text strings for this field are all stored contiguously in the region between FIELD.VAL.BEGIN.PTR and FIELD.VAL.END.PTR.  The index entry pointed to by ENTRY.PTR contains offsets within that region.") (LET ((PTRLOC (+ ENTRY.PTR FIELD.OFFSET)) THISPTR) (SETFILEPTR AR.INDEX.FILE PTRLOC) (SETQ THISPTR (\DWIN AR.INDEX.FILE)) (* ; "Offset in the region for this field for this ar.") (CONS (+ THISPTR FIELD.BEGIN) (- (if (<= (- AR.INDEX.ENTRY.END.PTR PTRLOC) AR.INDEX.ENTRY.SIZE) then (* ; "Fetching info for last ar in index, so the field goes until the end of this text region") (- FIELD.END FIELD.BEGIN) else (* ; "Get start of NEXT ar's info") (SETFILEPTR AR.INDEX.FILE (+ PTRLOC AR.INDEX.ENTRY.SIZE)) (\DWIN AR.INDEX.FILE)) THISPTR))) else (* ; "Not an ar.  This is for continuity, I guess") (CONS FIELD.END 0)))
)

(AR.GET.ENTRY.NUM
(LAMBDA (PTR) (* edited%: "13-Jul-84 11:42") (if (IGEQ PTR AR.INDEX.ENTRY.END.PTR) then MAX.FIXP else (SETFILEPTR AR.INDEX.FILE PTR) (\DWIN AR.INDEX.FILE)))
)
)

(RPAQ? AR.INDEX.DEFAULT.FIELDS '(Subject%: Source%: Date%: Submitter%: |Assigned To:| Attn%: 
                                           Status%: In/By%: |Problem Type:| Impact%: Difficulty%: 
                                           Frequency%: Priority%: System%: Subsystem%: Machine%: 
                                           Disk%: |Lisp Version:| |Source Files:| 
                                           |Microcode Version:| |Memory Size:| |File Server:| 
                                           |Server Software Version:| Edit-By%: Edit-Date%:))
(DECLARE%: EVAL@COMPILE DONTCOPY 

(FILESLOAD (LOADCOMP)
       ARQUERY)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS AR.INDEX.DEFAULT.FIELDS)
)


(DEFMACRO AR.ENTRY.PTR.TO.KEY.VAL.PTR (ENTRYPTR BEGINPTR)
   `(+ (IQUOTIENT (- ,ENTRYPTR AR.INDEX.ENTRY.BEGIN.PTR)
              AR.INDEX.ENTRY.SIZE)
       ,BEGINPTR))

(DEFMACRO ARSPECPUT (SPECS FIELDNAME PROP NEWVALUE)
   `(LISTPUT (CDR (ASSOC ,FIELDNAME ,SPECS))
           ,PROP
           ,NEWVALUE))
)
(PUTPROPS ARINDEX COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1992))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1938 15206 (AR.GATHER.NEW.AR.DATA 1948 . 2877) (AR.INDEX.CREATE 2879 . 4145) (
AR.GET.ENUMERATED.FIELD.KEYS 4147 . 4567) (AR.INDEX.FIND.ENTRY.PTR 4569 . 5415) (
AR.INDEX.REWRITE.ENTRY.DATA 5417 . 7851) (AR.INDEX.REWRITE.FIELD.DATA 7853 . 10113) (
AR.QFORM.FN.PRINT.INDEX 10115 . 10313) (AR.INDEX.PRINT 10315 . 12584) (AR.QFORM.FN.UPDATE 12586 . 
12857) (AR.INDEX.UPDATE 12859 . 15204)) (15207 18024 (AR.GET.FIELD.VAL.LENGTH 15217 . 16150) (
AR.GET.FIELD.VAL.PTR 16152 . 16705) (AR.GET.FIELD.VAL.SHAPE 16707 . 17840) (AR.GET.ENTRY.NUM 17842 . 
18022)))))
STOP
\ No newline at end of file
diff --git a/internal/library/ARQUERY b/internal/library/ARQUERY
new file mode 100644
index 00000000..66136205
--- /dev/null
+++ b/internal/library/ARQUERY
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "28-Sep-90 15:09:52" {DSK}<usr>local>lde>lispcore>internal>library>ARQUERY.;2 145824 

      changes to%:  (VARS ARQUERYCOMS)

      previous date%: "15-Jun-90 11:31:57" {DSK}<usr>local>lde>lispcore>internal>library>ARQUERY.;1
)


(* ; "
Copyright (c) 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT ARQUERYCOMS)

(RPAQQ ARQUERYCOMS
       [(COMS                                                (* ; "Query window management")
              (FNS AR.QFORM.CREATE AR.QFORM.GROUP.CREATE AR.QFORM.GET.DEFAULT.INDEX 
                   AR.QFORM.CREATE.ABORT AR.QFORM.GDATE AR.QUERY.WHENSELECTEDFN AR.QUERY.CLOSEFN 
                   AR.QUERY.SHRINKFN AR.QUERY.CLOSE/SHRINK AR.QUERY.EXPANDFN AR.QFORM.ICONFN 
                   AR.INDEX.OPEN AR.INDEX.FILE.REOPEN AR.INDEX.FILE.CLOSE AR.QFORM.QUERY 
                   AR.QFORM.BUTTONFN AR.GET.QLIST.PROMPT.MENU AR.QLIST.MENU.COMPARISONS 
                   AR.QFORM.PROMPT.LIST.FN AR.QFORM.TITLEMENU AR.MAKE.COMPARISON.STRING 
                   AR.GET.BUTTON.FIELD.AS.LIST))
        (COMS                                                (* ; "AR Browser window stuff")
              (FNS AR.BROWSER.PRINTFN AR#.FROM.ITEM AR.BROWSER.COMMANDFN AR.BROWSER.DO.COMMAND 
                   AR.BROWSER.SELECTED.ARS AR.BROWSER.DISPLAY AR.BROWSER.EDIT AR.BROWSER.HARDCOPY))
        (COMS                                                (* ; "Sorting")
              (FNS AR.QFORM.SORT AR.SORT.BY AR.GET.SLIST.PROMPT.MENU AR.ENSURE.QUERY.FIELDS 
                   AR.ENSURE.QUERY.DATA AR.COLLECT.ENTRY.FIELDS AR.ENSURY.QUERY.DATA.ITEM 
                   AR.AUGMENT.QUERY.FIELDS AR.KEYVALS.FROM.KEYLIST))
        (COMS                                                (* ; "Printing summaries")
              (FNS AR.QFORM.SUMMARY AR.QFORM.SUMMARY.TEXT AR.MAKE.SUMMARY.FILE 
                   AR.MAKE.SUMMARY.TEXT.FILE AR.QFORM.SUMMARY.TEDIT AR.QFORM.SUMMARIZE.CHECK 
                   AR.OPEN.IP.STREAM AR.PRINT.PADDED AR.IP.FROM.SUMMARY)
              (FNS AR.PRINT.SUMMARY AR.PRINT.SUMMARY.FIELD))
        (COMS                                                (* ; "Evaluating AR queries")
              (FNS AR.QUERY AR.QUERY.SMALLP AR.QUERY.EVAL AR.BAD.QUERY AR.QUERY.AND AR.QUERY.NAND 
                   AR.QUERY.SORT.CLAUSES AR.QUERY.SORT.ORDER AR.QUERY.SORT.VALUE AR.QUERY.OR 
                   AR.QUERY.COMBINE.RESULT)
              (FNS AR.QUERY.IS AR.QUERY.IS.EXACTLY AR.QUERY.COMPARE.ENUMERATED AR.QUERY.IS.EMPTY)
              (FNS AR.QUERY.HAS AR.COLLECT.SHAPES AR.COLLECT.SIZES AR.SPARSE.QUERYP 
                   AR.INDICES.FROM.FILEPTRS)
              (FNS AR.QUERY.COMPARE AR.QUERY.COMPARE.PARSE AR.QUERY.NUMBER AR.QUERY.PRODUCE.INDEXES 
                   AR.COLLECT.N AR.INDEX.FROM.NUMBER)
              (FNS AR.QUERY.DATE AR.QUERY.GENERAL.DATE AR.QUERY.PARSE.DATES AR.INDEX.FROM.DATE 
                   AR.DATE.FROM.INDEX)
              (FNS AR.NUMS.FROM.QUERY AR.ENTRY.PTR.FROM.INDEX AR.ENTRY.VALUE.FROM.INDEX 
                   AR.ENTRY.VALUE.NEXT AR.SELECT.WINDOW))
        [COMS                                                (* ; 
                                                           "Patch for nasty bug in \INCFILEPTR")
              (FNS AR.INCFILEPTR)
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (AND (CCODEP 'AR.INCFILEPTR (MOVD 'AR.INCFILEPTR
                                                                                   
                                                                                   '\PAGED.INCFILEPTR
                                                                                   NIL T]
        (COMS 
              (* ;; "Set up file names.  We use VARS on AR.INDEX.DEFAULT.FILE.NAME to force it correct in the case where the index is moving.  If user has set it to some disk file for manual caching, make that the cache name")

              (INITVARS (AR.INDEX.CACHE.FILE.NAME (AND (BOUNDP 'AR.INDEX.DEFAULT.FILE.NAME)
                                                       (STRPOS "DSK" (UNPACKFILENAME.STRING
                                                                      AR.INDEX.DEFAULT.FILE.NAME
                                                                      'HOST)
                                                              NIL NIL T NIL UPPERCASEARRAY)
                                                       AR.INDEX.DEFAULT.FILE.NAME))
                     (AR.ALWAYS.CACHE.INDEX :ASK))
              (VARS (AR.INDEX.DEFAULT.FILE.NAME "{AR:MV:Envos}<LispARs>AR.INDEX")))
        (VARS (AR.QFORM.TITLEMENU)
              AR.QFORM.FORMAT AR.QFORM.SPECS AR.QFORM.ICON AR.COMPARISON.OPERATORS)
        [INITVARS [AR.BROWSER.MENU.ITEMS '(("Display" AR.BROWSER.DISPLAY 
                                                  "Display selected AR in a readonly window")
                                           ("Edit" AR.BROWSER.EDIT "Edit selected AR in an AREdit window
 (uses same window as last time unless you select with middle button).")
                                           ("Hardcopy AR(s)" AR.BROWSER.HARDCOPY 
                                        "Make hardcopy of the complete content of the selected AR(s)"
                                                  ]
               [AR.QUERY.MENU.ITEMS '(("Query" (AR.QFORM.QUERY)
                                             "Search the AR database for ARs matching the Query List"
                                             )
                                      ("Sort" AR.QFORM.SORT 
                                         "Sort the ARs in the browser window using the new Sort List"
                                             )
                                      ("Hardcopy Summary" AR.QFORM.SUMMARY 
                        "Print to your default printer a summary of the ARs displayed in the browser"
                                             (SUBITEMS ("Text Summary" AR.QFORM.SUMMARY.TEXT 
                                                 "Make a plain text version of the summary on a file"
                                                              )
                                                    ("TEdit Summary" AR.QFORM.SUMMARY.TEDIT 
                                             "Edit (using TEdit) a plain text version of the summary"
                                                           ]
               (AR.WHENSELECTEDSHADE 4672)
               [AR.DISPLAY.FIELDS '((Status%: 5)
                                    (Subject%: 50)
                                    (Attn%: 15)
                                    (System%: 13)
                                    (Subsystem%: 13]
               [AR.SUMMARY.FIELDS '((Date%: 9 T)
                                    (System%: 13 T)
                                    (Subsystem%: 14)
                                    (Status%: 10 T)
                                    (Attn%: 13)
                                    (Subject%: 55)
                                    (Priority%: 10)
                                    (Difficulty%: 10)
                                    (Impact%: 8)
                                    (|Problem Type:| 13]
               (AR.TEDIT.FIELDS)
               (AR.SUMMARY.MIN.LINES 2)
               (AR.CLEANUP.SORT.ORDER '(System%: Subsystem%: Status%: Priority%: Impact%:))
               (AR.SORT.EQUIVALENTS '((Status%: (Open Open/Unreleased]
        (ADDVARS (AR.SORT.SPEC.ITEMS ("Standard Summary Order" [FUNCTION (LAMBDA NIL 
                                                                                AR.CLEANUP.SORT.ORDER
                                                                                ]
                                            
                                   "Sort order used by AR Cleanup when producing personal summaries."
                                            ))
               (AR.QUERY.SPEC.ITEMS ("Status is UnFixed" 
                                           "(OR (Status: >= Open/Unreleased) (Status: = Incomplete))"
                                           
                                         "AR is somehow Open, i.e., not Fixed, Declined or Obsoleted"
                                           )
                      ("Status is Resolved" "(AND (Status: >= Obsolete) (Status: <= Fixed)" 
                             "AR has been taken care of--Fixed, Declined, etc.")
                      ("Mandatory" 
           "(AND (Status: >= Open/Unreleased) (Priority: = Absolutely) (Problem%% Type: ~= Feature))"
                             "Non-Feature AR has priority Absolutely and is still open somehow")))
        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS AR.INDEX.DATA ARQUERYDATA ARINDEXDESCR)
               (GLOBALVARS AR.QFORM.ICON AR.BROWSER.MENU.ITEMS AR.QUERY.MENU.ITEMS 
                      AR.COMPARISON.OPERATORS AR.QFORM.TITLEMENU)
               (LOCALVARS . T)
               (FUNCTIONS WITH.AR.QUERY ARSPECGET)
               [P [CL:PROCLAIM (CONS 'CL:SPECIAL (RECORDFIELDNAMES 'AR.INDEX.DATA]
                  (CASE DFNFLG
                      ((PROP ALLPROP) 
                                                             (* ; 
                               "When I load this file PROP, need to get these defs evaled, grumble")
                         [LET ((DFNFLG T))
                              (MAPC '(WITH.AR.QUERY ARSPECGET)
                                    (FUNCTION (LAMBDA (FN)
                                                     (CL:EVAL (GETDEF FN 'FUNCTIONS NIL '(NOERROR]))
                                                             (* ; 
           "These aren't ours, but declare them to reduce the warnings from compiler & masterscope")
                  (CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT DEFAULTLANDPAGEREGION]
               (CONSTANTS (AR.BYTES.PER.PTR 4))
               (FILES (SOURCE)
                      TABLEBROWSERDECLS))
        (DECLARE%: EVAL@COMPILE DOCOPY
               (P (CL:PROCLAIM '(CL:SPECIAL AR.INDEX.DEFAULT.FILE.NAME AR.INDEX.CACHE.FILE.NAME 
                                       AR.ALWAYS.CACHE.INDEX AR.QFORM.SPECS AR.QFORM.FORMAT 
                                       AR.WHENSELECTEDSHADE AR.DISPLAY.FIELDS AR.SUMMARY.MIN.LINES 
                                       AR.SUMMARY.FIELDS AR.TEDIT.FIELDS AR.QUERY.SPEC.ITEMS 
                                       AR.SORT.SPEC.ITEMS AR.SORT.EQUIVALENTS])



(* ; "Query window management")

(DEFINEQ

(AR.QFORM.CREATE
(LAMBDA (AR.INDEX.FILE.NAME WINDOW DONTSPAWN) (* ; "Edited 25-Feb-87 10:47 by jds") (* ;; "Create an AR query form.  Queries will be done against AR.INDEX.FILE.NAME.  WINDOW, if supplied, will be used as the main query window.  If DONTSPAWN is T, this'll be completed before the  function returns; otherwise it'll be spawned as an asynchronous process.") (COND (DONTSPAWN (* ; "Want the window created before returning.") (AR.QFORM.GROUP.CREATE AR.INDEX.FILE.NAME WINDOW)) (T (* ; "Let the caller go ahead, while we make the window on our own time.") (ADD.PROCESS (LIST (FUNCTION AR.QFORM.GROUP.CREATE) (KWOTE AR.INDEX.FILE.NAME) (KWOTE WINDOW)) (QUOTE NAME) (QUOTE AR.QUERY.FORM.TEMP)))))
)

(AR.QFORM.GROUP.CREATE
(LAMBDA (INDEX.FILENAME WINDOW NO.BROWSER) (* ; "Edited  4-Aug-88 12:52 by bvm") (* ;;; "Set up a query-window group (main window, summary browser, and prompt window).  Queries will be done against AR.INDEX.FILE.NAME.  WINDOW, if supplied, will be used as the query window.  If NO.BROWSER is true, this window is being created solely to hang queries off, so only the main window and a prompt window are supplied.") (LET* ((BROWSERMENUW (MENUWINDOW (create MENU ITEMS _ AR.BROWSER.MENU.ITEMS MENUFONT _ ARBOLDFONT CENTERFLG _ T MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION AR.BROWSER.COMMANDFN)))) (QUERYMENUW (MENUWINDOW (create MENU ITEMS _ AR.QUERY.MENU.ITEMS MENUFONT _ ARBOLDFONT CENTERFLG _ T MENUROWS _ 1 WHENSELECTEDFN _ (FUNCTION AR.BROWSER.COMMANDFN)))) (MENUHEIGHT (WINDOWPROP QUERYMENUW (QUOTE HEIGHT))) (FONTHEIGHT (FONTPROP (OR (WINDOWP WINDOW) DEFAULTFONT) (QUOTE HEIGHT))) (PROMPTHEIGHT (HEIGHTIFWINDOW (TIMES 2 FONTHEIGHT))) (BROWSERHEIGHT (HEIGHTIFWINDOW (TIMES 8 FONTHEIGHT) T)) (QUERYHEIGHT (HEIGHTIFWINDOW (TIMES 3 (+ 2 (FONTPROP ARBOLDFONT (QUOTE HEIGHT)))) T)) QFORMWINDOW QREG REG QFORM.ENTRY.WINDOW DATA) (* ;; "set up main window.  I assume the two menus are the same height") (if (NOT (WINDOWP WINDOW)) then (LET ((OTHERHEIGHTS (+ QUERYHEIGHT MENUHEIGHT MENUHEIGHT PROMPTHEIGHT))) (* ; "Height of all the fixed window parts") (SETQ REG (OR (REGIONP WINDOW) (GETREGION 400 (+ BROWSERHEIGHT OTHERHEIGHTS)))) (SETQ QFORMWINDOW (CREATEW (SETQ QREG (create REGION using REG HEIGHT _ QUERYHEIGHT BOTTOM _ (+ (fetch (REGION BOTTOM) of REG) BROWSERHEIGHT MENUHEIGHT))) (CONCAT AR.IDENTIFICATION.STRING " Query Specification"))) (replace (REGION HEIGHT) of REG with (- (fetch (REGION HEIGHT) of REG) OTHERHEIGHTS))) else (SETQ QREG (WINDOWPROP (SETQ QFORMWINDOW WINDOW) (QUOTE REGION))) (SETQ REG (create REGION LEFT _ (fetch (REGION LEFT) of QREG) BOTTOM _ (- (fetch (REGION BOTTOM) of QREG) BROWSERHEIGHT MENUHEIGHT) WIDTH _ (fetch (REGION WIDTH) of QREG) HEIGHT _ BROWSERHEIGHT))) (WINDOWPROP QFORMWINDOW (QUOTE AR.WINDOW.PROC.NAME) (QUOTE AR.QUERY.FORM)) (WINDOWPROP QFORMWINDOW (QUOTE MINSIZE) (CONS 200 QUERYHEIGHT)) (WINDOWPROP QFORMWINDOW (QUOTE MAXSIZE) (CONS MAX.SMALLP (fetch (REGION HEIGHT) of QREG))) (WINDOWPROP QFORMWINDOW (QUOTE ICONFN) (FUNCTION AR.QFORM.ICONFN)) (WINDOWADDPROP QFORMWINDOW (QUOTE SHRINKFN) (FUNCTION AR.QUERY.SHRINKFN) T) (WINDOWADDPROP QFORMWINDOW (QUOTE EXPANDFN) (FUNCTION AR.QUERY.EXPANDFN) T) (* ;; "Attach query operations menu") (ATTACHWINDOW QUERYMENUW QFORMWINDOW (QUOTE TOP) (QUOTE JUSTIFY)) (GETPROMPTWINDOW QFORMWINDOW 2) (if (SETQ DATA (AR.INDEX.OPEN QFORMWINDOW (OR INDEX.FILENAME (AR.QFORM.GET.DEFAULT.INDEX QFORMWINDOW)))) then (WINDOWPROP QFORMWINDOW (QUOTE AR.INDEX.DATA) DATA) (WINDOWPROP QFORMWINDOW (QUOTE AR.INDEX.MONITORLOCK) (CREATE.MONITORLOCK "AR Index")) (if (NOT NO.BROWSER) then (* ; "Add browser window and its menu, and install query menu in query window") (ATTACHWINDOW BROWSERMENUW QFORMWINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY)) (SETQ QFORM.ENTRY.WINDOW (CREATEW REG (CONCAT AR.IDENTIFICATION.STRING " Query Browser"))) (ATTACHWINDOW QFORM.ENTRY.WINDOW QFORMWINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY)) (* ; "Browser window goes on very bottom so that the scroll bar doesn't get in the way") (WINDOWPROP QFORMWINDOW (QUOTE QFORM.ENTRY.WINDOW) QFORM.ENTRY.WINDOW) (WINDOWPROP QFORM.ENTRY.WINDOW (QUOTE MINSIZE) (CONS 10 (HEIGHTIFWINDOW (TIMES 2 FONTHEIGHT) T))) (AR.FORM.CREATE QFORMWINDOW ARBOLDFONT AR.QFORM.SPECS AR.QFORM.FORMAT (LIST (QUOTE TITLEMENUFN) (FUNCTION AR.QFORM.TITLEMENU)))) (* ; "Don't install CLOSEFN til now, so that we can override TEdit's") (WINDOWADDPROP QFORMWINDOW (QUOTE CLOSEFN) (FUNCTION AR.QUERY.CLOSEFN) T))))
)

(AR.QFORM.GET.DEFAULT.INDEX
(LAMBDA (QFORMWINDOW) (* ; "Edited  4-Aug-88 12:53 by bvm") (* ;; "Returns the file name of the index to open for QFORMWINDOW.  This fusses about caching.") (if (OR (NULL AR.INDEX.CACHE.FILE.NAME) (NULL AR.ALWAYS.CACHE.INDEX)) then (* ; "No cache, or we're supposed to ignore it, go straight to the master") AR.INDEX.DEFAULT.FILE.NAME else (LET ((*UPPER-CASE-FILE-NAMES* NIL)) (WINDOWPROP QFORMWINDOW (QUOTE PROCESS) (THIS.PROCESS)) (WINDOWADDPROP QFORMWINDOW (QUOTE CLOSEFN) (FUNCTION AR.QFORM.CREATE.ABORT)) (* ; "Arrange to go away if user aborts by closing window.") (CL:UNWIND-PROTECT (PROG ((MASTER (INFILEP AR.INDEX.DEFAULT.FILE.NAME)) (CACHE (INFILEP AR.INDEX.CACHE.FILE.NAME)) MASTERDATE CACHEDATE CLOSEHACK) (if (NULL MASTER) then (AR.PROMPT.PRINT QFORMWINDOW "Can't find " AR.INDEX.DEFAULT.FILE.NAME " so will use cache") (RETURN (OR CACHE AR.INDEX.CACHE.FILE.NAME)) elseif (NULL CACHE) then (PRINTOUT QFORMWINDOW "Local cache " AR.INDEX.CACHE.FILE.NAME " does not yet exist") elseif (AND (SETQ CACHEDATE (GETFILEINFO CACHE (QUOTE ICREATIONDATE))) (SETQ MASTERDATE (GETFILEINFO MASTER (QUOTE ICREATIONDATE))) (>= CACHEDATE MASTERDATE)) then (* ; "Cache is up to date") (RETURN CACHE) else (CL:FORMAT QFORMWINDOW "Local cache (~A) is older than master index (~A)" (AR.QFORM.GDATE CACHEDATE) (AR.QFORM.GDATE MASTERDATE))) (RETURN (PROG1 (SELECTQ (COND ((EQ AR.ALWAYS.CACHE.INDEX T) :COPY) (T (* ; "Ask user whether to cache") (LET* ((CHOICEMENU (create MENU ITEMS _ (BQUOTE (("Copy master index to local cache" :COPY "Copy the master index file to the local cache file (this will take a while), then use the local cache.") ("Use master index directly" :NEW "Use the master index directly, without caching it.") (\,@ (AND CACHE (QUOTE (("Use local cache (ignore master)" :OLD "Use the local index cache, even though there is a newer master index"))))))) CENTERFLG _ T MENUFONT _ ARBOLDFONT MENUOUTLINESIZE _ 4)) (REG (WINDOWPROP QFORMWINDOW (QUOTE REGION)))) (* ;; "Position the menu centered directly below the query window, in the space that will later be occupied by the browser") (MENU CHOICEMENU (create POSITION XCOORD _ (+ (fetch (REGION LEFT) of REG) (IQUOTIENT (- (fetch (REGION WIDTH) of REG) (fetch IMAGEWIDTH of CHOICEMENU)) 2)) YCOORD _ (- (fetch (REGION BOTTOM) of REG) (fetch IMAGEHEIGHT of CHOICEMENU))) T)))) (:NEW MASTER) (:OLD CACHE) (:COPY (LET ((OLDTITLE (WINDOWPROP QFORMWINDOW (QUOTE TITLE) (CONCAT "Fetching " AR.IDENTIFICATION.STRING " Index"))) (OLDICONFN (WINDOWPROP QFORMWINDOW (QUOTE ICONFN) (FUNCTION TEXTICON))) W) (* ; "So if you want to shrink the window, you see its state") (AR.PROMPT.PRINT QFORMWINDOW "Copying " MASTER "...") (AR.PROMPT.PRINT QFORMWINDOW " finished writing " (SETQ CACHE (COPYFILE MASTER (OR CACHE AR.INDEX.CACHE.FILE.NAME)))) (WINDOWPROP QFORMWINDOW (QUOTE TITLE) OLDTITLE) (WINDOWPROP QFORMWINDOW (QUOTE ICONFN) OLDICONFN) (WINDOWPROP QFORMWINDOW (QUOTE ICONWINDOW) NIL) CACHE)) (SHOULDNT)) (CLEARW QFORMWINDOW)))) (WINDOWDELPROP QFORMWINDOW (QUOTE CLOSEFN) (FUNCTION AR.QFORM.CREATE.ABORT)) (WINDOWPROP QFORMWINDOW (QUOTE PROCESS) NIL)))))
)

(AR.QFORM.CREATE.ABORT
(LAMBDA (WINDOW) (* ; "Edited 29-Feb-88 15:19 by bvm") (LET ((P (WINDOWPROP WINDOW (QUOTE PROCESS)))) (AND P (PROCESSP P) (PROCESS.EVAL P (QUOTE (ERROR!))))))
)

(AR.QFORM.GDATE
(LAMBDA (DT) (* ; "Edited 29-Feb-88 15:21 by bvm") (if DT then (GDATE DT (DATEFORMAT DAY.OF.WEEK DAY.SHORT NO.SECONDS)) else "Date unknown?"))
)

(AR.QUERY.WHENSELECTEDFN
(LAMBDA (ITEM) (* ; "Edited  1-Mar-88 11:27 by bvm") (* ;; "WHENSELECTEDFN for Query and Sort spec button menus.  Similar to default, but don't evaluate the cadr.") (if (NLISTP ITEM) then ITEM else (CADR ITEM)))
)

(AR.QUERY.CLOSEFN
(LAMBDA (WINDOW) (* ; "Edited  8-Aug-88 11:10 by bvm") (AR.QUERY.CLOSE/SHRINK WINDOW :CLOSE)))

(AR.QUERY.SHRINKFN
(LAMBDA (WINDOW) (* ; "Edited  8-Aug-88 11:10 by bvm") (AR.QUERY.CLOSE/SHRINK WINDOW :SHRINK)))

(AR.QUERY.CLOSE/SHRINK
(LAMBDA (WINDOW HOW) (* ; "Edited  8-Aug-88 11:10 by bvm") (* ;; "CLOSEFN or SHRINKFN on Query window: check that we're not busy, then kill the tedit proc, close the index, etc.") (PROG ((BUSYPROC (WINDOWPROP WINDOW (QUOTE BROWSER.BUSY)))) (if (AND BUSYPROC (PROCESSP BUSYPROC)) then (if (NOT (MOUSECONFIRM (CL:FORMAT NIL "Browser is busy with ~A;
Click LEFT to confirm aborting it.") T)) then (RETURN (QUOTE DON'T)) else (DEL.PROCESS BUSYPROC))) (if (EQ HOW :SHRINK) then (* ; "save the textstream") (WINDOWPROP WINDOW (QUOTE SAVED-TEXTSTREAM) (WINDOWPROP WINDOW (QUOTE TEXTSTREAM)))) (AR.KILL.ATTACHED.TEDIT.CLOSEFN WINDOW) (AR.INDEX.FILE.CLOSE WINDOW) (if (EQ HOW :CLOSE) then (* ; "Snap link to AR display window") (LET ((W (WINDOWPROP WINDOW (QUOTE AR.DISPLAY.WINDOW) NIL))) (AND (WINDOWP W) (WINDOWPROP W (QUOTE AR.QUERY.WINDOW) NIL)))) (RETURN NIL)))
)

(AR.QUERY.EXPANDFN
(LAMBDA (WINDOW) (* ; "Edited 29-Feb-88 16:29 by bvm") (* ;; "On expanding the query window, rebuild the Tedit process behind the query buttons.") (LET ((TS (WINDOWPROP WINDOW (QUOTE SAVED-TEXTSTREAM) NIL))) (AND TS (AR.INSTALL.TEDITSTREAM WINDOW TS (LIST (QUOTE TITLEMENUFN) (FUNCTION NILL))))))
)

(AR.QFORM.ICONFN
(LAMBDA (WINDOW OLDICON) (* ; "Edited 29-Feb-88 16:10 by bvm") (OR OLDICON (ICONW AR.QFORM.ICON NIL (WINDOWPROP WINDOW (QUOTE ICONPOSITION)))))
)

(AR.INDEX.OPEN
(LAMBDA (QFORMWINDOW FILENAME) (* ; "Edited 25-Jul-88 15:15 by bvm") (* ;; "Open the ar index, setting the variable AR.INDEX.FILE to the stream, and returning the index data") (* ;; "The last 32 bits of the file point at the start of the index data.") (PROG (*UPPER-CASE-FILE-NAMES* INDEX.STREAM CONDITION INDEX.DATA) (AR.PROMPT.PRINT QFORMWINDOW T "Opening index file... ") (CL:MULTIPLE-VALUE-SETQ (INDEX.STREAM CONDITION) (IGNORE-ERRORS (OPENSTREAM FILENAME (QUOTE INPUT) (QUOTE OLD)))) (if CONDITION then (AR.PROMPT.PRINT QFORMWINDOW (CL:FORMAT NIL "failed: ~A" CONDITION)) (RETURN NIL)) (replace (STREAM MAXBUFFERS) of INDEX.STREAM with 40) (SETFILEPTR INDEX.STREAM (- (GETEOFPTR INDEX.STREAM) BYTESPERCELL)) (SETFILEPTR INDEX.STREAM (\DWIN INDEX.STREAM)) (SETQ INDEX.DATA (READ INDEX.STREAM FILERDTBL)) (COND ((NOT (type? AR.INDEX.DATA INDEX.DATA)) (CLOSEF INDEX.STREAM) (AR.PROMPT.PRINT QFORMWINDOW "failed: Bad index format") (RETURN NIL))) (replace (AR.INDEX.DATA AR.INDEX.FILE) of INDEX.DATA with INDEX.STREAM) (if (NOT (fetch (AR.INDEX.DATA AR.MAX.INDEX) of INDEX.DATA)) then (* ; "Max.index not normally stored in file, we derive it") (SETQ INDEX.DATA (create AR.INDEX.DATA using INDEX.DATA AR.MAX.INDEX _ (SUB1 (IQUOTIENT (- (fetch (AR.INDEX.DATA AR.INDEX.ENTRY.END.PTR) of INDEX.DATA) (fetch (AR.INDEX.DATA AR.INDEX.ENTRY.BEGIN.PTR) of INDEX.DATA)) (fetch (AR.INDEX.DATA AR.INDEX.ENTRY.SIZE) of INDEX.DATA)))))) (AR.PROMPT.PRINT QFORMWINDOW "done.") (RETURN INDEX.DATA)))
)

(AR.INDEX.FILE.REOPEN
(LAMBDA (QFORMWINDOW) (* ; "Edited 26-Feb-88 21:12 by bvm") (if (NOT (OPENP AR.INDEX.FILE)) then (AR.PROMPT.PRINT QFORMWINDOW " [Re-opening index file...") (SETQ AR.INDEX.FILE (LET (*UPPER-CASE-FILE-NAMES*) (OPENSTREAM (FULLNAME AR.INDEX.FILE) (QUOTE INPUT) (QUOTE OLD)))) (replace (STREAM MAXBUFFERS) of AR.INDEX.FILE with 40) (AR.PROMPT.PRINT QFORMWINDOW " done] ") (replace (AR.INDEX.DATA AR.INDEX.FILE) of (WINDOWPROP QFORMWINDOW (QUOTE AR.INDEX.DATA)) with AR.INDEX.FILE)))
)

(AR.INDEX.FILE.CLOSE
(LAMBDA (QFORMWINDOW) (* ; "Edited 17-Feb-88 12:16 by bvm") (* ;; "Closes query's index file if it is open") (LET ((INDEX.FILE (fetch (AR.INDEX.DATA AR.INDEX.FILE) of (WINDOWPROP QFORMWINDOW (QUOTE AR.INDEX.DATA))))) (if (OPENP INDEX.FILE) then (CLOSEF INDEX.FILE))))
)

(AR.QFORM.QUERY
(LAMBDA (QFORMWINDOW) (* ; "Edited 26-Feb-88 10:12 by bvm") (AR.QUERY QFORMWINDOW (CONS (QUOTE AND) (AR.GET.BUTTON.FIELD.AS.LIST QFORMWINDOW (QUOTE |Query List:|))) (AR.GET.BUTTON.FIELD.AS.LIST QFORMWINDOW (QUOTE |Sort List:|))))
)

(AR.QFORM.BUTTONFN
(LAMBDA (OBJ SEL WINDOW) (* mjs "17-Feb-85 16:03") (AR.QFORM.ACTIONFN (CAR (fetch (TEXTOBJ \WINDOW) of (fetch (SELECTION \TEXTOBJ) of SEL))) (IMAGEOBJPROP OBJ (QUOTE MBTEXT))))
)

(AR.GET.QLIST.PROMPT.MENU
  [LAMBDA (QFORMWINDOW)                                  (* ; "Edited 15-Jun-90 11:03 by jds")
    (OR
     (WINDOWPROP QFORMWINDOW 'AR.QLIST.PROMPT.MENU)
     (LET*
      ((INDEX.DATA (WINDOWPROP QFORMWINDOW 'AR.INDEX.DATA))
       (FIELD.SPECS (fetch (AR.INDEX.DATA AR.INDEX.FIELD.SPECS) of INDEX.DATA))
       (VAL
        (create
         MENU
         TITLE _ "Query Options"
         ITEMS _
         [APPEND
          '("(NOT" "(OR" "(AND")
          (SORT
           [CONS
            `[Number%: NIL "Use submenu to choose a numeric range" (SUBITEMS
                                                                    ,@(AR.QLIST.MENU.COMPARISONS
                                                                       'Number%:]
            (for FIELD.NAME in (fetch (AR.INDEX.DATA AR.INDEX.FIELD.LIST) of 
                                                                                           INDEX.DATA
                                              ) bind FIELD.KEYLIST SUBVALS
               collect (if (SETQ FIELD.KEYLIST (ARSPECGET FIELD.SPECS FIELD.NAME
                                                              'ENUMERATED.FIELD.KEYLIST))
                               then                      (* ; "Get enumerated values")
                                     [SETQ SUBVALS (for KEY.VAL in FIELD.KEYLIST
                                                      by (CDDR KEY.VAL)
                                                      collect (LIST KEY.VAL (LIST FIELD.NAME 
                                                                                      KEY.VAL]
                                     (if (EQ FIELD.NAME 'Subsystem%:)
                                         then            (* ; "sort the random values of subsystem.  I hate to special-case it like this, but for simple enumerated items the values are already sorted in some interesting order")
                                               (SORT SUBVALS T))
                                     `(,FIELD.NAME NIL 
                                             "Match against a specific value from submenu ->"
                                             (SUBITEMS ("--blank--" (,FIELD.NAME))
                                                    ,@SUBVALS))
                             else                        (* ; "Can only search against strings")
                                   `(,FIELD.NAME (,FIELD.NAME HAS)
                                           "Search this field for specified substring"
                                           ,@(AND (STRPOS "Date" FIELD.NAME)
                                                  `((SUBITEMS ("has" (,FIELD.NAME HAS)
                                                                     
                                                          "Search this field for specified substring"
                                                                     )
                                                           ,@(AR.QLIST.MENU.COMPARISONS 
                                                                    FIELD.NAME]
           T)
          [AND AR.QUERY.SPEC.ITEMS (LIST `("Special" NIL "Select custom queries from submenu"
                                                 (SUBITEMS ,@AR.QUERY.SPEC.ITEMS]
          '(("--Clear--" :CLEAR "Clear the Query spec and start over"]
         WHENSELECTEDFN _ (FUNCTION AR.QUERY.WHENSELECTEDFN)
         CENTERFLG _ T)))
      (WINDOWPROP QFORMWINDOW 'AR.QLIST.PROMPT.MENU VAL)
      VAL])

(AR.QLIST.MENU.COMPARISONS
(LAMBDA (FIELD.NAME) (* ; "Edited 16-Mar-88 17:16 by bvm") (* ;; "Return a set of menu items for arithmetic comparisons on FIELD.NAME") (for OP in AR.COMPARISON.OPERATORS collect (LIST OP (LIST FIELD.NAME OP))))
)

(AR.QFORM.PROMPT.LIST.FN
(LAMBDA (OBJ SEL WINDOW) (* ; "Edited 20-Jul-88 15:56 by bvm") (LET* ((*PACKAGE* *INTERLISP-PACKAGE*) (TOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) (WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of TOBJ))) (OPERATION (IMAGEOBJPROP OBJ (QUOTE MBTEXT))) (ITEM (MENU (SELECTQ OPERATION (|Query List:| (AR.GET.QLIST.PROMPT.MENU WINDOW)) (|Sort List:| (AR.GET.SLIST.PROMPT.MENU WINDOW)) (SHOULDNT)))) ISP) (* ; "Set cursor back to point at button") (if ITEM then (PROG ((FIELD.SEL (MBUTTON.FIND.NEXT.FIELD TOBJ (fetch (SELECTION CH#) of SEL))) FIELD.END.CH#) (if (EQ ITEM :CLEAR) then (TEDIT.DELETE TOBJ FIELD.SEL) else (if (NOT (STRINGP ITEM)) then (* ;; "Turn the item into something that can be read back by query reader, which uses FILERDTBL.") (SETQ ITEM (if (OR (NLISTP ITEM) (LISTP (CDDR ITEM))) then (MKSTRING (OR ITEM (RETURN)) T FILERDTBL) elseif (EQ (CAR ITEM) (QUOTE FUNCTION)) then (* ; "Computed item") (SETQ ITEM (CL:FUNCALL (CADR ITEM) WINDOW)) (if (NULL ITEM) then (RETURN) elseif (STRINGP ITEM) else (if (AND (LISTP ITEM) (EQ OPERATION (QUOTE |Sort List:|))) then (* ; "Strip off parens for sort spec") (SUBSTRING (MKSTRING ITEM T FILERDTBL) 2 -2) else (MKSTRING ITEM T FILERDTBL))) elseif (EQ (CADR ITEM) (QUOTE HAS)) then (* ; "Substring search") (CONCAT "(" (MKSTRING (CAR ITEM) T FILERDTBL) " HAS >>string<<)") elseif (MEMB (CADR ITEM) AR.COMPARISON.OPERATORS) then (DESTRUCTURING-BIND (FIELD.NAME OP) ITEM (LET ((TEMPLATE (if (EQ FIELD.NAME (QUOTE Number%:)) then (* ; "no quotes") (LIST ">>" "num<<") else (* ; "Have to quote dates") (LIST "%">>" "date<<%"")))) (* ; "Comparison (fieldname op valuetype)") (CONCAT "(" (MKSTRING FIELD.NAME T FILERDTBL) (if (EQ OP (QUOTE btwn)) then (* ; "E.g., (fieldname >= >>lonum<< <= >>hinum<<)") (CONCAT (AR.MAKE.COMPARISON.STRING (QUOTE >=) TEMPLATE) (AR.MAKE.COMPARISON.STRING (QUOTE <=) TEMPLATE)) else (AR.MAKE.COMPARISON.STRING OP TEMPLATE)) ")"))) else (* ; "Specific value search") (SETQ ISP (MKSTRING (LIST (CAR ITEM) (QUOTE IS) (CADR ITEM)) T FILERDTBL))))) (TEDIT.INSERT TOBJ ITEM (SETQ FIELD.END.CH# (+ (fetch (SELECTION CH#) of FIELD.SEL) (fetch (SELECTION DCH) of FIELD.SEL)))) (TEDIT.INSERT TOBJ " " (+ FIELD.END.CH# (NCHARS ITEM))) (COND ((STRPOS ">>" ITEM) (TEDIT.SETSEL TOBJ FIELD.END.CH# 0) (TEDIT.NEXT TOBJ)) (ISP (* ; "Delete-select the IS so you can change it to , say, >") (TEDIT.SETSEL TOBJ (+ FIELD.END.CH# (STRPOS " IS " ITEM)) 2 NIL T)))))) (CURSORPOSITION (create POSITION XCOORD _ 20 YCOORD _ (DSPYPOSITION NIL WINDOW)) WINDOW)))
)

(AR.QFORM.TITLEMENU
(LAMBDA (WINDOW) (* ; "Edited 20-Jul-88 16:12 by bvm") (LET ((OP (MENU (OR AR.QFORM.TITLEMENU (SETQ AR.QFORM.TITLEMENU (create MENU ITEMS _ (REMOVE (QUOTE btwn) AR.COMPARISON.OPERATORS) CENTERFLG _ T)))))) (if OP then (* ; "Type this into the window") (TEDIT.INSERT (TEXTSTREAM WINDOW) OP))))
)

(AR.MAKE.COMPARISON.STRING
(LAMBDA (OP TEMPLATE) (* ; "Edited 16-Mar-88 17:11 by bvm") (CONCAT " " OP " " (CAR TEMPLATE) (SELECTQ OP ((> >=) "lo") ((< <=) "hi") "") (CADR TEMPLATE)))
)

(AR.GET.BUTTON.FIELD.AS.LIST
(LAMBDA (FORMWINDOW FIELD.NAME) (* ; "Edited 24-Feb-88 21:10 by bvm") (* ;; "READ, using FILERDTBL, the value of FIELD.NAME of FORMWINDOW, returning a list.") (LET* ((TOBJ (TEXTOBJ FORMWINDOW)) (BUTTON (AR.FIND.BUTTON TOBJ FIELD.NAME)) (FIELD.VAL (MBUTTON.NEXT.FIELD.AS.TEXT TOBJ (CDR BUTTON))) (STREAM (OPENSTRINGSTREAM FIELD.VAL)) (*PARENS* 0) *MAX-PARENS*) (SETFILEINFO STREAM (QUOTE ENDOFSTREAMOP) (FUNCTION (LAMBDA (STREAM) (* ;; "Handler for eof error.  We try adding some closing parens") (if (NULL *MAX-PARENS*) then (SETQ *MAX-PARENS* (CL:COUNT #\( FIELD.VAL))) (if (> (add *PARENS* 1) *MAX-PARENS*) then (* ; "Let's not try to add more close parens than open") (AR.PROMPT.PRINT FORMWINDOW T "Malformed " FIELD.NAME ", command aborted") (ERROR!)) (* ; "return a closing paren") (CHARCODE ")")))) (bind X (*READTABLE* _ FILERDTBL) until (EQ (SETQ X (CL:READ STREAM NIL STREAM)) STREAM) collect X finally (if (> *PARENS* 0) then (* ; "We had to add some right parens to make it balance, so fix the button field.") (TEDIT.INSERT TOBJ (ALLOCSTRING *PARENS* (CHARCODE ")")) (+ (CDR BUTTON) (NCHARS FIELD.VAL) 1))))))
)
)



(* ; "AR Browser window stuff")

(DEFINEQ

(AR.BROWSER.PRINTFN
  [LAMBDA (BROWSER ITEM WINDOW)                          (* ; "Edited 15-Jun-90 11:06 by jds")

    (* ;; "Repaint the line in the Query browser window corresponding to this AR.")

    (LET ((ENTRY.DATA (fetch TIDATA of ITEM))
          (STREAM (GETSTREAM WINDOW))
          (MAINW (MAINWINDOW WINDOW)))
         (if (NOT (fetch (ARQUERYDATA ARQCOMPLETE) of ENTRY.DATA))
             then (AR.ENSURY.QUERY.DATA.ITEM MAINW ENTRY.DATA))

         (* ;; "The fields in ENTRY.DATA contain either a value or a (ptr length) pair for string fields.  The specs in AR.DISPLAY.FIELDS give (fieldname desiredwidth).  We place 2 spaces between fields.")

         (PRINTOUT WINDOW |.I5| (fetch (ARQUERYDATA ARQ#) of ENTRY.DATA)
                "  ")
         (for SPEC in (WINDOWPROP MAINW 'AR.DISPLAY.FIELDS) as VALUE
            in (fetch (ARQUERYDATA ARQFIELDS) of ENTRY.DATA)
            bind WIDTH LEN (SCRATCH _ (WINDOWPROP MAINW 'AR.FORM.SCRATCH.STREAM))
            do (SETQ WIDTH (CADR SPEC))
                  (if (NOT VALUE)
                      then (SPACES (+ WIDTH 2)
                                      STREAM)
                    elseif (LISTP VALUE)
                      then                               (* ; "bits are on scratch file")
                            (SETFILEPTR SCRATCH (CAR VALUE))
                            (COPYBYTES SCRATCH STREAM (SETQ LEN (MIN (CADR VALUE)
                                                                     WIDTH)))
                            (SPACES (- (+ WIDTH 2)
                                       LEN)
                                   STREAM)
                    else                                 (* ; "VALUE is it")
                          (AR.PRINT.PADDED VALUE STREAM 1 WIDTH (+ WIDTH 2])

(AR#.FROM.ITEM
  [LAMBDA (ITEM QFORMWINDOW)                             (* ; "Edited 15-Jun-90 11:06 by jds")
    (LET ((DATA (fetch TIDATA of ITEM)))
         (if (NOT (fetch (ARQUERYDATA ARQCOMPLETE) of DATA))
             then (AR.ENSURY.QUERY.DATA.ITEM QFORMWINDOW DATA))
         (fetch (ARQUERYDATA ARQ#) of DATA])

(AR.BROWSER.COMMANDFN
(LAMBDA (ITEM MENU BUTTON) (* ; "Edited 20-Jul-88 18:42 by bvm") (* ;; "WHENSELECTEDFN for the AR query browser menu.  We spawn a process to do the work") (LET* ((MAINW (MAINWINDOW (WFROMMENU MENU))) (BROWSERW (WINDOWPROP MAINW (QUOTE QFORM.ENTRY.WINDOW)))) (if BROWSERW then (LET ((BROWSER (WINDOWPROP BROWSERW (QUOTE TABLEBROWSER))) (FN (CADR ITEM))) (if (if (NLISTP FN) then (* ; "Normal case, require that there be something in the tablebrowser") BROWSER else (* ; "Do it anyway, e.g., Query") (SETQ FN (CAR FN))) then (ADD.PROCESS (BQUOTE ((\, (FUNCTION AR.BROWSER.DO.COMMAND)) (QUOTE (\, MAINW)) (QUOTE (\, BROWSER)) (QUOTE (\, FN)) (QUOTE (\, ITEM)) (QUOTE (\, MENU)) (QUOTE (\, BUTTON)))) (QUOTE NAME) (CONCAT "AR-" (CAR ITEM)) (QUOTE BEFOREEXIT) (QUOTE DON'T)) else (AR.PROMPT.PRINT MAINW :CLEAR "There are no ARs in the browser."))))))
)

(AR.BROWSER.DO.COMMAND
(LAMBDA (WINDOW BROWSER FN ITEM MENU BUTTON) (* ; "Edited  4-Aug-88 11:14 by bvm") (* ;; "Started up in its own process to perform the action specified by the menu item.  Menu functions get called with arglist (window browser button).") (if (NOT (MEMBER ITEM (fetch (MENU ITEMS) of MENU))) then (* ; "Subitem--shade the main item") (SETQ ITEM (find I in (fetch (MENU ITEMS) of MENU) suchthat (MEMBER ITEM (CDR (CADDDR I)))))) (if (WINDOWPROP WINDOW (QUOTE BROWSER.BUSY) (THIS.PROCESS)) then (TB.BROWSER.BUSY BROWSER) else (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (WINDOW ITEM MENU PROCNAME) (WINDOWPROP WINDOW (QUOTE BROWSER.BUSY) NIL) (SHADEITEM ITEM MENU WHITESHADE) (if (AND PROCNAME (EQ PROCNAME (PROCESSPROP (TTY.PROCESS) (QUOTE NAME)))) then (* ; "Give the tty back, unless someone has already taken it") (TTY.PROCESS (WINDOWPROP WINDOW (QUOTE PROCESS)))))) WINDOW ITEM MENU (LET ((PROC (WINDOWPROP WINDOW (QUOTE PROCESS)))) (if (AND PROC (TTY.PROCESSP PROC)) then (* ; "Take TTY away from query window so that cursor isn't flashing there") (TTY.PROCESS (QUOTE BACKGROUND)) (PROCESSPROP (TTY.PROCESS) (QUOTE NAME)))))) (SHADEITEM ITEM MENU AR.WHENSELECTEDSHADE) (AR.PROMPT.CLEAR WINDOW) (CL:FUNCALL FN WINDOW BROWSER BUTTON)))
)

(AR.BROWSER.SELECTED.ARS
(LAMBDA (WINDOW BROWSER LASTPROP) (* ; "Edited 17-Feb-88 14:04 by bvm") (* ;; "Return list of items selected in BROWSER.  If LASTPROP is specified, choose exactly one of the items, based on the idea that the item in window's LASTPROP property was most recently accessed, so if that one is selected, go on to the next.  Returns NIL if no selected item, or selection has run out.") (LET ((SELECTEDARS (TB.COLLECT.ITEMS BROWSER (QUOTE SELECTED)))) (if (NULL SELECTEDARS) then (AR.PROMPT.PRINT WINDOW "No AR is selected") NIL elseif (NULL LASTPROP) then (* ; "return them all") SELECTEDARS else (PROG ((LASTITEM (WINDOWPROP WINDOW LASTPROP)) ITEM NEXTITEM TAIL) (if (NULL (CDR SELECTEDARS)) then (* ;; "Only one selected, so choose that one item, or go on to the next if that one was most recently displayed/edited.") (if (EQ (SETQ ITEM (CAR SELECTEDARS)) LASTITEM) then (* ; "Advance selection to next item") (if (SETQ NEXTITEM (TB.NTH.ITEM BROWSER (ADD1 (fetch TI# of ITEM)))) then (TB.UNSELECT.ITEM BROWSER ITEM) (TB.SELECT.ITEM BROWSER (SETQ ITEM NEXTITEM)) else (RETURN (AR.PROMPT.PRINT WINDOW "That was the last AR")))) else (* ; "Cycle thru a group of selected ars.") (if (NULL (SETQ TAIL (MEMB LASTITEM SELECTEDARS))) then (* ; "None recently displayed, so show the first") (SETQ ITEM (CAR SELECTEDARS)) elseif (CDR TAIL) then (* ; "Choose the next") (SETQ ITEM (CADR TAIL)) else (WINDOWPROP WINDOW LASTPROP NIL) (RETURN (AR.PROMPT.PRINT WINDOW "That was the last selected AR" T "Click again to cycle back to the first one.")))) (RETURN ITEM)))))
)

(AR.BROWSER.DISPLAY
(LAMBDA (WINDOW BROWSER BUTTON) (* ; "Edited  4-Aug-88 14:42 by bvm") (* ;; "Displays the selected AR in a readonly display window") (LET ((ITEM (AR.BROWSER.SELECTED.ARS WINDOW BROWSER (QUOTE LAST.DISPLAYED.AR))) DISPLAYW) (if ITEM then (TB.NORMALIZE.ITEM BROWSER ITEM) (* ; "Scroll so visible, if necessary") (if (OR (EQ BUTTON (QUOTE MIDDLE)) (NOT (WINDOWP (SETQ DISPLAYW (WINDOWPROP WINDOW (QUOTE AR.DISPLAY.WINDOW)))))) then (* ; "Make a display window") (SETQ DISPLAYW (CREATEW (REGIONP DISPLAYW) (CONCAT AR.IDENTIFICATION.STRING " display window"))) (WINDOWPROP DISPLAYW (QUOTE ICONFN) (FUNCTION TEXTICON)) (if (NEQ BUTTON (QUOTE MIDDLE)) then (* ; "Remember it for next time") (WINDOWPROP WINDOW (QUOTE AR.DISPLAY.WINDOW) DISPLAYW) (WINDOWPROP DISPLAYW (QUOTE AR.QUERY.WINDOW) WINDOW) (WINDOWADDPROP DISPLAYW (QUOTE CLOSEFN) (FUNCTION (LAMBDA (WINDOW) (* ; "When display window is closed, make the query window remember only the region") (LET ((Q (WINDOWPROP WINDOW (QUOTE AR.QUERY.WINDOW) NIL))) (AND Q (WINDOWPROP Q (QUOTE AR.DISPLAY.WINDOW) (WINDOWREGION WINDOW))))))))) (AR.DISPLAY (AR#.FROM.ITEM ITEM WINDOW) DISPLAYW) (WINDOWPROP WINDOW (QUOTE LAST.DISPLAYED.AR) ITEM))))
)

(AR.BROWSER.EDIT
(LAMBDA (WINDOW BROWSER BUTTON) (* ; "Edited  5-Aug-88 11:07 by bvm") (* ;; "Edits the selected AR in an AREdit window") (PROG ((ITEM (AR.BROWSER.SELECTED.ARS WINDOW BROWSER (QUOTE LAST.EDITED.AR))) EDITW TOBJ MENUW) (if (NULL ITEM) then (RETURN)) (TB.NORMALIZE.ITEM BROWSER ITEM) (* ; "Scroll so visible, if necessary") (if (EQ BUTTON (QUOTE MIDDLE)) then (* ; "Always get a new window and don't hang onto it") elseif (AND (WINDOWP (SETQ EDITW (WINDOWPROP WINDOW (QUOTE AR.EDIT.WINDOW)))) (OR (OPENWP EDITW) (OPENWP (WINDOWPROP EDITW (QUOTE ICONWINDOW))))) then (* ; "Use this window--it's still open, or is shrunk") else (AR.PROMPT.PRINT WINDOW "Select AR Edit window to use" T "or click >>here<< to make new window.") (SETQ EDITW (WHICHW (GETPOSITION))) (AR.PROMPT.CLEAR WINDOW) (if (NULL EDITW) then (GO ABORT) elseif (EQ EDITW (GETPROMPTWINDOW WINDOW)) then (* ; "Want to make a new one") (SETQ EDITW NIL) elseif (EQ (WINDOWPROP (SETQ EDITW (OR (WINDOWPROP EDITW (QUOTE MAINWINDOW)) (WINDOWPROP EDITW (QUOTE ICONFOR)) EDITW)) (QUOTE AR.WINDOW.PROC.NAME)) (QUOTE AR.FORM)) then (WINDOWPROP WINDOW (QUOTE AR.EDIT.WINDOW) EDITW) else (GO ABORT))) (if EDITW then (* ; "Check to see that the specified window is useable") (SETQ MENUW (AR.GET.MENU.FROM.MAIN.WINDOW EDITW)) (if (OR (NULL (SETQ TOBJ (WINDOWPROP MENUW (QUOTE TEXTOBJ)))) (AR.TOBJ.ACTIVEP TOBJ) (NULL (SETQ TOBJ (WINDOWPROP EDITW (QUOTE TEXTOBJ)))) (AR.TOBJ.ACTIVEP TOBJ)) then (if (NOT (MOUSECONFIRM "That window is busy, click LEFT to get new window" T (GETPROMPTWINDOW WINDOW))) then (GO ABORT)) (SETQ EDITW NIL) elseif (TEDIT.STREAMCHANGEDP (TEXTSTREAM EDITW)) then (AR.PROMPT.PRINT WINDOW T "The form in that window has not been saved." T "Click LEFT to confirm smashing it anyway.") (if (MOUSECONFIRM T T (GETPROMPTWINDOW WINDOW) T) then (* ; "Mark stream unchanged so the Get will proceed") (AR.PROMPT.CLEAR WINDOW) (TEDIT.STREAMCHANGEDP (TEXTSTREAM EDITW) T) elseif (MOUSECONFIRM "Do you want to use a new window?" NIL (GETPROMPTWINDOW WINDOW)) then (SETQ EDITW NIL) else (GO ABORT)))) (if EDITW then (* ; "Still have a window to play with") (if (NOT (OPENWP EDITW)) then (* ; "Explicitly open it before Get to avoid some attached window glitches.  TEdit expandfn grabs tty, so give it back") (EXPANDW (WINDOWPROP EDITW (QUOTE ICONWINDOW))) (TTY.PROCESS T)) (AR.FORM.PROGRAMMATIC.GET MENUW (AR#.FROM.ITEM ITEM WINDOW)) else (SETQ EDITW (AR.FORM.GROUP.CREATE (AR#.FROM.ITEM ITEM WINDOW))) (if (NEQ BUTTON (QUOTE MIDDLE)) then (* ; "Remember it for next time") (WINDOWPROP WINDOW (QUOTE AR.EDIT.WINDOW) EDITW))) (WINDOWPROP WINDOW (QUOTE LAST.EDITED.AR) ITEM) (* ; "Mark this item as both edited and displayed") (RETURN (WINDOWPROP WINDOW (QUOTE LAST.DISPLAYED.AR) ITEM)) ABORT (AR.PROMPT.PRINT WINDOW T "Command aborted")))
)

(AR.BROWSER.HARDCOPY
(LAMBDA (WINDOW BROWSER BUTTON) (* ; "Edited  4-Aug-88 14:42 by bvm") (LET ((ARS (AR.BROWSER.SELECTED.ARS WINDOW BROWSER))) (if (AND ARS (SETQ ARS (AR.HARDCOPY (for X in ARS collect (AR#.FROM.ITEM X WINDOW)) (GETPROMPTWINDOW WINDOW)))) then (AR.PROMPT.PRINT WINDOW T "Done, " ARS))))
)
)



(* ; "Sorting")

(DEFINEQ

(AR.QFORM.SORT
(LAMBDA (QFORMWINDOW TBROWSER) (* ; "Edited 22-Jul-88 16:48 by bvm") (* ;; "Resort the ars in a browser by a new query spec") (WITH.AR.QUERY QFORMWINDOW (LET ((SLIST (AR.GET.BUTTON.FIELD.AS.LIST QFORMWINDOW (QUOTE |Sort List:|))) (ENTRIES (WINDOWPROP QFORMWINDOW (QUOTE AR.ENTRIES)))) (if (NULL ENTRIES) then (AR.PROMPT.PRINT QFORMWINDOW "There is nothing to sort.") elseif (EQUAL (WINDOWPROP QFORMWINDOW (QUOTE AR.ENTRY.ALIST.SLIST)) SLIST) then (AR.PROMPT.PRINT QFORMWINDOW "List is already sorted") elseif (SETQ ENTRIES (if (NULL SLIST) then (* ; "Sort by AR#.  Equivalent to sorting by Index, conveniently") (AR.PROMPT.PRINT QFORMWINDOW "Sorting by AR#...") (SORT ENTRIES T) else (AR.SORT.BY QFORMWINDOW ENTRIES SLIST))) then (AR.PROMPT.PRINT QFORMWINDOW "done.") (TB.REPLACE.ITEMS TBROWSER (for ENTRY in ENTRIES collect (create TABLEITEM TIDATA _ ENTRY))) (WINDOWPROP QFORMWINDOW (QUOTE AR.ENTRY.ALIST.SLIST) SLIST) (WINDOWPROP QFORMWINDOW (QUOTE AR.ENTRIES) ENTRIES)))))
)

(AR.SORT.BY
  [LAMBDA (QFORMWINDOW ENTRIES SLIST)                    (* ; "Edited 15-Jun-90 11:06 by jds")

    (* ;; "Sorts the list of ENTRIES by the fields listed in SLIST.  This function must be called underneath WITH.AR.QUERY.  Returns NIL if it can't sort.")

    (if (NULL SLIST)
        then                                             (* ; "The null sort")
              NIL
      else (AR.PROMPT.PRINT QFORMWINDOW "Sorting by ")
            (AR.ENSURE.QUERY.FIELDS QFORMWINDOW SLIST)
            (for NAME in (REVERSE SLIST) bind (PAIRS _ (for ENTRY in ENTRIES
                                                                      collect (CONS 0 ENTRY)))
                                                       (FIELDS _ (WINDOWPROP QFORMWINDOW 
                                                                        'AR.FIELD.DESCRIPTIONS))
                                                       (MULTIPLIER _ 1)
                                                       NUM KEYLIST VAL NKEYS KEYINDEX
               do 

                     (* ;; "PAIRS is a list associating with each entry its total sort value.  Take the fields in reverse order, so that the first field will have the greatest effect.  Multiply the numeric value of an AR's field by a multiplier arranged to space out the values of all the fields.  Note that null fields come out with index 0, so sort to the top.")

                     (AR.PROMPT.PRINT QFORMWINDOW NAME " ")
                     (SETQ KEYLIST (ARSPECGET AR.INDEX.FIELD.SPECS NAME 
                                          'ENUMERATED.FIELD.KEYLIST))
                     (SETQ NKEYS (IQUOTIENT (LENGTH KEYLIST)
                                        2))
                     [for PAIR in (CDR (CL:ASSOC NAME AR.SORT.EQUIVALENTS))
                        do                               (* ; 
                   "List of values all at same priority, that being the priority of the first item")
                              (LET [(N (LISTGET KEYLIST (CAR PAIR]
                                   (for K in (CDR PAIR) do (push KEYLIST K N]
                     (if (EQ NKEYS 0)
                         then (AR.PROMPT.PRINT QFORMWINDOW T "Can't sort on field " NAME)
                               (RETURN NIL))
                     (SETQ KEYINDEX (CL:POSITION NAME FIELDS :KEY (FUNCTION CAR)))
                     [for PAIR in PAIRS when [SETQ VAL (CL:NTH KEYINDEX
                                                                          (fetch (ARQUERYDATA
                                                                                      ARQALLFIELDS)
                                                                             of (CDR PAIR]
                        do (add (CAR PAIR)
                                      (TIMES MULTIPLIER (LISTGET KEYLIST VAL]
                     (SETQ MULTIPLIER (TIMES MULTIPLIER (ADD1 NKEYS)))
               finally 

                     (* ;; "Sort the pairs in order of increasing sort value.")

                     (RETURN (MAPCAR [SORT PAIRS (FUNCTION (LAMBDA (X Y)
                                                             (if (< (CAR X)
                                                                        (CAR Y))
                                                               elseif (NOT (> (CAR X)
                                                                                  (CAR Y)))
                                                                 then 
                                                             (* ; 
                               "If values are equal, sort by index (equivalent to sorting by AR#).")
                                                                       (< (fetch (ARQUERYDATA
                                                                                      ARQINDEX)
                                                                             of (CDR X))
                                                                          (fetch (ARQUERYDATA
                                                                                      ARQINDEX)
                                                                             of (CDR Y]
                                    (FUNCTION CDR])

(AR.GET.SLIST.PROMPT.MENU
  [LAMBDA (QFORMWINDOW)                                  (* ; "Edited 15-Jun-90 11:04 by jds")
    (OR (WINDOWPROP QFORMWINDOW 'AR.SLIST.PROMPT.MENU)
        (LET* [(INDEX.DATA (WINDOWPROP QFORMWINDOW 'AR.INDEX.DATA))
               (FIELD.SPECS (fetch (AR.INDEX.DATA AR.INDEX.FIELD.SPECS) of INDEX.DATA))
               (VAL (create MENU
                           TITLE _ "Sort Options"
                           ITEMS _ [NCONC (SORT (for FIELD.NAME in (fetch (AR.INDEX.DATA
                                                                                       
                                                                                  AR.INDEX.FIELD.LIST
                                                                                       ) of
                                                                                         INDEX.DATA)
                                                   when (ARSPECGET FIELD.SPECS FIELD.NAME
                                                                   'ENUMERATED.FIELD.KEYLIST)
                                                   collect FIELD.NAME))
                                          [AND AR.SORT.SPEC.ITEMS
                                               (LIST `("Special" NIL 
                                                             "Select custom sort orders from submenu"
                                                             (SUBITEMS ,@AR.SORT.SPEC.ITEMS]
                                          '(("--Clear--" :CLEAR "Clear the Sort spec and start over"]
                           CENTERFLG _ T
                           WHENSELECTEDFN _ (FUNCTION AR.QUERY.WHENSELECTEDFN]
              (WINDOWPROP QFORMWINDOW 'AR.SLIST.PROMPT.MENU VAL)
              VAL])

(AR.ENSURE.QUERY.FIELDS
(LAMBDA (QFORMWINDOW FIELDS) (* ; "Edited 29-Feb-88 11:50 by bvm") (* ;; "Ensures that all the entries in the query window have the specified fields.  If not, we fetch them.  Returns the complete list of fields stored in the entries.") (AR.AUGMENT.QUERY.FIELDS QFORMWINDOW (for F in FIELDS bind (KNOWN _ (WINDOWPROP QFORMWINDOW (QUOTE AR.FIELD.DESCRIPTIONS))) collect F unless (ASSOC F KNOWN))) (AR.ENSURE.QUERY.DATA QFORMWINDOW FIELDS))
)

(AR.ENSURE.QUERY.DATA
  [LAMBDA (QFORMWINDOW FIELDS ENTRIES)                   (* ; "Edited 15-Jun-90 11:09 by jds")

    (* ;; 
  "Makes sure that all of FIELDS are filled in for ENTRIES, or all entries in window if NIL.")

    (PROG* ((INDEX.STREAM AR.INDEX.FILE)
            (DESCRS (WINDOWPROP QFORMWINDOW 'AR.FIELD.DESCRIPTIONS))
            (NFIELDS (LENGTH DESCRS))
            SCRATCH)
           [OR ENTRIES (SETQ ENTRIES (WINDOWPROP QFORMWINDOW 'AR.ENTRIES]
           (if (for E in ENTRIES always (fetch (ARQUERYDATA ARQCOMPLETE)
                                                           of E))
               then                                      (* ; "Nothing to do")
                     (RETURN))
           (if [for ENTRY in (CDR ENTRIES) bind (LASTINDEX _ (CAAR ENTRIES))
                      thereis (> LASTINDEX (SETQ LASTINDEX (CAR ENTRY]
               then 

                     (* ;; "Entries are out of order (e.g., we have been called to fetch fields to print or to resort).  More efficient for us to work in sorted order, so make ourselves a sorted copy.  Only copy the first cons, so that our destructive changes to the tail will affect original ENTRIES, too.")

                     (SETQ ENTRIES (SORT (for ENTRY in ENTRIES
                                            collect (CONS (CAR ENTRY)
                                                              (CDR ENTRY)))
                                         T)))

     (* ;; "Gather the data in two passes: first, scan the table of fixed-size entries, gathering AR numbers plus the address info of string fields.  In the second pass, scan the region associated with each field, collecting values.  This results in better locality of reference in the index file.")

           (if [OR (EQ FIELDS T)
                       (for FIELD in FIELDS thereis (FIXP (fetch (ARINDEXDESCR 
                                                                                        ARIOFFKEYS)
                                                                         of (CL:ASSOC FIELD 
                                                                                       DESCRS]
               then                                      (* ; "There are some string fields to fill in, might as well get them all (since they all live in the same place)")
                                                             (* ; 
      "Need scratch stream to store the values (could store as strings, but that's more expensive)")
                     (SETFILEPTR (SETQ SCRATCH (AR.GET.SCRATCH.STREAM QFORMWINDOW))
                            -1)
                     (SETFILEPTR INDEX.STREAM AR.INDEX.ENTRY.BEGIN.PTR) 
                                                             (* ; "Start of fixed-size entries")
                     (for ENTRY in ENTRIES bind (LASTOFFSET _ 0)
                                                         (LASTINDEX _ 0)
                                                         INDEX unless (fetch (ARQUERYDATA
                                                                                      ARQCOMPLETE)
                                                                             of ENTRY)
                        do 

                              (* ;; "This loop goes entry by entry.  Loop invariant is that the file is positioned at LASTOFFSET of LASTINDEX.  Collect pointers for string fields, ignore enumerated fields.")

                              [SETQ LASTOFFSET
                               (AR.COLLECT.ENTRY.FIELDS
                                ENTRY DESCRS (PROGN          (* ; 
            "Relative to this new INDEX, the LASTOFFSET that we read at is this much farther back.")
                                                    (- LASTOFFSET (TIMES (- (SETQ INDEX
                                                                             (fetch (ARQUERYDATA
                                                                                         ARQINDEX)
                                                                                of ENTRY))
                                                                            LASTINDEX)
                                                                         AR.INDEX.ENTRY.SIZE]
                              (SETQ LASTINDEX INDEX)))

     (* ;; "At this point, each of ENTRIES is filled with values of either NIL for enumerated fields or (offset length) for variable fields.  Now take a field at a time, and fill in the real values.")

           (for D in DESCRS as I from 0
              bind BEGIN VALUES LASTINDEX [FINALI _ (AND (EQ FIELDS T)
                                                             (SUB1 (LENGTH DESCRS]
              when (AND (SETQ BEGIN (fetch (ARINDEXDESCR ARIBEGIN) of D))
                            (OR (EQ FIELDS T)
                                (CL:MEMBER (fetch (ARINDEXDESCR ARINAME) of D)
                                       FIELDS)))
              do (if (SETQ VALUES (LISTP (fetch (ARINDEXDESCR ARIOFFKEYS) of D)))
                         then                            (* ; "For enumerated fields, we'll continue to use the incfileptr trick.  File is always positioned to read the byte for LASTINDEX, which is also bytecount relative to BEGIN")
                               (SETFILEPTR INDEX.STREAM BEGIN)
                               (SETQ LASTINDEX 0))
                    (for ENTRY in ENTRIES bind PAIR TAIL KEY
                       unless (fetch (ARQUERYDATA ARQCOMPLETE) of ENTRY)
                       do [if (NULL (CDR ENTRY))
                                  then                   (* ; 
                                                          "First time for this guy, get some space")
                                        (RPLACD ENTRY (CONS NIL (to NFIELDS
                                                                   collect '?]
                             (SETQ TAIL (CL:NTHCDR I (fetch (ARQUERYDATA ARQALLFIELDS)
                                                        of ENTRY))) 
                                                             (* ; 
                                                           "(CAR TAIL) is where we want the value")
                             [if VALUES
                                 then                    (* ; "Get byte for enumerated value")
                                       [if (EQ (CAR TAIL)
                                                   '?)
                                           then (\INCFILEPTR INDEX.STREAM (- (CAR ENTRY)
                                                                                 LASTINDEX))
                                                 (SETQ LASTINDEX (ADD1 (CAR ENTRY)))
                                                 (RPLACA TAIL (COND
                                                                 ((NEQ (SETQ KEY (BIN INDEX.STREAM))
                                                                       0)
                                                             (* ; "Zero denotes the null value")
                                                                  (CL:NTH (SUB1 KEY)
                                                                         VALUES]
                               elseif (AND (SETQ PAIR (CAR TAIL))
                                               (< (CAR PAIR)
                                                  0))
                                 then                    (* ; "String field--PAIR is (-offset-1 length).  Copy its contents to the scratch stream, and replace the offset pointer with the scratch file ptr")
                                       (SETFILEPTR INDEX.STREAM (- BEGIN (CAR PAIR)
                                                                   1)) 
                                                             (* ; 
                                                           "i.e. (+ begin (- -1 (car pair)))")
                                       (RPLACA PAIR (PROG1 (GETFILEPTR SCRATCH)
                                                        (COPYBYTES INDEX.STREAM SCRATCH (CADR PAIR)))
                                              ]
                             (if (EQ I FINALI)
                                 then                    (* ; "All done now")
                                       (replace (ARQUERYDATA ARQCOMPLETE) of ENTRY
                                          with T])

(AR.COLLECT.ENTRY.FIELDS
  [LAMBDA (ENTRY DESCRS LASTOFFSET)                      (* ; "Edited 15-Jun-90 11:09 by jds")

    (* ;; "Fill in the %"Fixed-size%" entry fields in ENTRY, an item from an AR query browser.  DESCRS is the description list, paralleling the ALLFIELDS tail of ENTRY.  LASTOFFSET is the offset past the last entry read from the file, relative to this entry.  We smash ENTRY and return a new LASTOFFSET.")

    [if (NULL (CDR ENTRY))
        then                                             (* ; 
                                                          "First time for this guy, get some space")
              (RPLACD ENTRY (CONS NIL (for D in DESCRS collect '?]
    [for D in DESCRS as TAIL on (fetch (ARQUERYDATA ARQALLFIELDS) of ENTRY)
       bind (INCREMENT _ AR.INDEX.ENTRY.SIZE)
             (STREAM _ AR.INDEX.FILE)
             (MAX.INDEXP _ (EQ (fetch (ARQUERYDATA ARQINDEX) of ENTRY)
                               AR.MAX.INDEX))
             OFFSET LEN VALUE when (AND (FIXP (SETQ OFFSET (fetch (ARINDEXDESCR ARIOFFKEYS)
                                                                  of D)))
                                            (EQ (CAR TAIL)
                                                '?))
       do                                                (* ; "This is a field stored in the fixed-size entry table.  Bump the fileptr to the next spot.  We use \incfileptr to avoid creating number boxes.")
             (\INCFILEPTR STREAM (- OFFSET LASTOFFSET))      (* ; 
                   "Equivalent to (setfileptr index.stream (ar.entry.ptr.from.index index offset))")
             (SETQ LASTOFFSET (+ OFFSET AR.BYTES.PER.PTR))
             (SETQ VALUE (\DWIN STREAM))
             (RPLACA TAIL (if (EQ OFFSET 0)
                              then                       (* ; 
                                            "We just read the AR number, that's all we need to do.")
                                    VALUE
                            else                         (* ; "We just read the offset of the field data.  Need to get the offset of the next AR's field in order to compute the length")
                                  (SETQ LEN (- (if MAX.INDEXP
                                                   then  (* ; "There is no next one, so all we know is this field goes to the end.  Sure would have been nice to have a dummy n+1 entry.")
                                                         (- (fetch (ARINDEXDESCR ARIEND)
                                                               of D)
                                                            (fetch (ARINDEXDESCR ARIBEGIN)
                                                               of D))
                                                 else (\INCFILEPTR STREAM (- INCREMENT 
                                                                                 AR.BYTES.PER.PTR))
                                                       (add LASTOFFSET INCREMENT) 
                                                             (* ; 
                                           "We have bumped file pointer exactly one index forward.")
                                                       (\DWIN STREAM))
                                               VALUE))       (* ; "For now, we return (-offset-1 length), unless length is 0, in which case the field is empty.  The extra -1 is because offset can be zero.")
                                  (AND (NEQ LEN 0)
                                       (LIST (- -1 VALUE)
                                             LEN]
    LASTOFFSET])

(AR.ENSURY.QUERY.DATA.ITEM
  [LAMBDA (QFORMWINDOW ENTRY)                            (* ; "Edited 15-Jun-90 11:09 by jds")

    (* ;; "Fill in all the fields of one particular ENTRY.  This is a relatively inefficient operation, since we duplicate effort used by reading data for the other entries, and we read the file in a suboptimal order.  It exists solely for the PRINTFN, and is hacked specially.  This code is coordinated with AR.ENSURE.QUERY.DATA.")

    (RESETLST                                                (* ; 
                                                  "Code begins with a manual WITH.AR.QUERY here...")
        (LET [(LOCK (WINDOWPROP QFORMWINDOW 'AR.INDEX.MONITORLOCK))
              (INDEX.DATA (WINDOWPROP QFORMWINDOW 'AR.INDEX.DATA]
             (if (NOT (OBTAIN.MONITORLOCK LOCK T T))
                 then                                    (* ; 
                                                           "Lock is in use. Don't steal mouse")
                       (AR.PROMPT.PRINT QFORMWINDOW " [Browser busy; please wait] ")
                       (ALLOW.BUTTON.EVENTS)
                       (OBTAIN.MONITORLOCK LOCK NIL T))
             (LET ((AR.INDEX.FILE (fetch (AR.INDEX.DATA AR.INDEX.FILE) of INDEX.DATA))
                   (AR.INDEX.ENTRY.SIZE (fetch (AR.INDEX.DATA AR.INDEX.ENTRY.SIZE) of 
                                                                                           INDEX.DATA
                                               ))
                   (AR.INDEX.ENTRY.BEGIN.PTR (fetch (AR.INDEX.DATA AR.INDEX.ENTRY.BEGIN.PTR)
                                                of INDEX.DATA))
                   (AR.MAX.INDEX (fetch (AR.INDEX.DATA AR.MAX.INDEX) of INDEX.DATA))
                   (DESCRS (WINDOWPROP QFORMWINDOW 'AR.FIELD.DESCRIPTIONS))
                   (SCRATCH (WINDOWPROP QFORMWINDOW 'AR.FORM.SCRATCH.STREAM))
                   (INDEX (fetch (ARQUERYDATA ARQINDEX) of ENTRY)))

                  (* ;; "Note: We Know that only these first 4 variables are needed by the code that follows, not the whole set")

                  (if (NOT (OPENP AR.INDEX.FILE))
                      then (AR.INDEX.FILE.REOPEN QFORMWINDOW))
                  (SETFILEPTR SCRATCH -1)
                  (SETFILEPTR AR.INDEX.FILE (AR.ENTRY.PTR.FROM.INDEX INDEX))
                                                             (* ; "Position at start of item")
                  (AR.COLLECT.ENTRY.FIELDS ENTRY DESCRS 0)
                                                             (* ; "Get fixed table items")
                  [for D in DESCRS as TAIL on (fetch (ARQUERYDATA ARQALLFIELDS)
                                                                 of ENTRY)
                     bind BEGIN VALUES PAIR KEY when (SETQ BEGIN (fetch (ARINDEXDESCR
                                                                                     ARIBEGIN)
                                                                            of D))
                     do (if (LISTP (SETQ VALUES (fetch (ARINDEXDESCR ARIOFFKEYS)
                                                           of D)))
                                then                     (* ; 
                      "Enumerated field--read a byte and translate it.  VALUES is the list of keys")
                                      [if (EQ (CAR TAIL)
                                                  '?)
                                          then (SETFILEPTR AR.INDEX.FILE (+ BEGIN INDEX))
                                                (RPLACA TAIL (COND
                                                                ((NEQ (SETQ KEY (BIN AR.INDEX.FILE))
                                                                      0)
                                                             (* ; "Zero denotes the null value")
                                                                 (CL:NTH (SUB1 KEY)
                                                                        VALUES]
                              elseif (AND (SETQ PAIR (CAR TAIL))
                                              (< (CAR PAIR)
                                                 0))
                                then                     (* ; "String field--PAIR is (-offset-1 length).  Copy its contents to the scratch stream, and replace the offset pointer with the scratch file ptr")
                                      (SETFILEPTR AR.INDEX.FILE (- BEGIN (CAR PAIR)
                                                                   1)) 
                                                             (* ; 
                                                           "i.e. (+ begin (- -1 (car pair)))")
                                      (RPLACA PAIR (PROG1 (GETFILEPTR SCRATCH)
                                                       (COPYBYTES AR.INDEX.FILE SCRATCH (CADR PAIR)))
                                             ]
                  (replace (ARQUERYDATA ARQCOMPLETE) of ENTRY with T))))])

(AR.AUGMENT.QUERY.FIELDS
  [LAMBDA (QFORMWINDOW FIELDS)                           (* ; "Edited 15-Jun-90 11:07 by jds")

    (* ;; "Add FIELDS to the set of field info stored in the entries in QFORMWINDOW")

    (LET [(NFIELDS (LENGTH FIELDS))
          [DESCRS (for FIELD.NAME in FIELDS
                     collect (LET* ((FIELD.SPEC (CDR (ASSOC FIELD.NAME AR.INDEX.FIELD.SPECS)))
                                        (FIELD.OFFSET (LISTGET FIELD.SPEC 'FIELD.OFFSET))
                                        KEYS)
                                       (create ARINDEXDESCR
                                              ARINAME _ FIELD.NAME
                                              ARIOFFKEYS _ (if FIELD.OFFSET
                                                             elseif (SETQ KEYS
                                                                         (LISTGET FIELD.SPEC
                                                                                
                                                                                '
                                                                             ENUMERATED.FIELD.KEYLIST
                                                                                ))
                                                               then 
                                                             (* ; 
                                                        "Turn this plist into a simple sorted list")
                                                                     (AR.KEYVALS.FROM.KEYLIST
                                                                      KEYS)
                                                             else (HELP 
                                                 "Field for display is neither string nor enumerated"
                                                                            FIELD.NAME))
                                              ARIBEGIN _ (LISTGET FIELD.SPEC 'FIELD.BEGIN.PTR)
                                              ARIEND _ (AND FIELD.OFFSET (LISTGET FIELD.SPEC
                                                                                'FIELD.END.PTR]
          (OLDDESCRS (WINDOWPROP QFORMWINDOW 'AR.FIELD.DESCRIPTIONS))
          (ENTRIES (WINDOWPROP QFORMWINDOW 'AR.ENTRIES]
         (if (NULL OLDDESCRS)
             then                                        (* ; "No info stored yet, so include number as well, but no need to lengthen non-existent data.  Also, flush old text info")
                   (\SETEOFPTR (AR.GET.SCRATCH.STREAM QFORMWINDOW)
                          0)
                   (WINDOWPROP QFORMWINDOW 'AR.FIELD.DESCRIPTIONS (CONS (create ARINDEXDESCR
                                                                               ARINAME _ 'Number%:
                                                                               ARIOFFKEYS _ 0)
                                                                        DESCRS))
           elseif (> NFIELDS 0)
             then (for ENTRY in ENTRIES when (CDR ENTRY)
                         do                              (* ; 
                                     "Only need to do this for entries that already have something")
                               (NCONC ENTRY (to NFIELDS collect '?))
                               (replace (ARQUERYDATA ARQCOMPLETE) of ENTRY with NIL))
                   (WINDOWPROP QFORMWINDOW 'AR.FIELD.DESCRIPTIONS (NCONC OLDDESCRS DESCRS])

(AR.KEYVALS.FROM.KEYLIST
(LAMBDA (KEYLIST) (* ; "Edited 26-Feb-88 16:32 by bvm") (* ;; "Takes an AR index ENUMERATED.FIELD.KEYLIST and turns it into a list of values in order, such that the first element is the value for key 1.") (if (for VAL in (CDR KEYLIST) by (CDDR VAL) as I from 1 always (EQ I VAL)) then (* ;; "Keys are in order, so it's easy to make the list.  This is an optimization with the knowledge that all keys are currently stored this way.") (for KEY in KEYLIST by (CDDR KEY) collect KEY) else (HELP "Enumerated keys out of order.  RETURN to continue") (LET ((KEYVALS (SORT (for TAIL on KEYLIST by (CDDR TAIL) collect (LIST (CADR TAIL) (CAR TAIL))) T))) (for I from 1 while KEYVALS collect (AND (EQ I (CAAR KEYVALS)) (CADR (pop KEYVALS)))))))
)
)



(* ; "Printing summaries")

(DEFINEQ

(AR.QFORM.SUMMARY
(LAMBDA (QFORMWINDOW) (* ; "Edited  4-Aug-88 13:02 by bvm") (* ;; "Handles the %"Hardcopy Summary%" command -- sends summary straight to printer") (if (AR.QFORM.SUMMARIZE.CHECK QFORMWINDOW) then (AR.PROMPT.PRINT QFORMWINDOW "Printing summary...") (LET ((STREAM (AR.OPEN.IP.STREAM NIL (CONCAT AR.IDENTIFICATION.STRING " Summary")))) (CL:UNWIND-PROTECT (AR.PRINT.SUMMARY QFORMWINDOW STREAM) (CLOSEF STREAM)) (AR.PROMPT.PRINT QFORMWINDOW "done."))))
)

(AR.QFORM.SUMMARY.TEXT
(LAMBDA (QFORMWINDOW) (* ; "Edited 20-Jul-88 18:49 by bvm") (* ;; "Handle the %"Text Summary%" command--make a text file containing summary") (if (AR.QFORM.SUMMARIZE.CHECK QFORMWINDOW) then (LET ((FILE (PROMPTFORWORD "File Name: " (WINDOWPROP QFORMWINDOW (QUOTE AR.SUMMARY.FILE.NAME)) NIL (GETPROMPTWINDOW QFORMWINDOW) NIL (QUOTE TTY)))) (AR.PROMPT.CLEAR QFORMWINDOW) (if FILE then (WINDOWPROP QFORMWINDOW (QUOTE AR.SUMMARY.FILE.NAME) FILE) (* ; "Save specified name in case of abort, but later store the fully qualified name") (WINDOWPROP QFORMWINDOW (QUOTE AR.SUMMARY.FILE.NAME) (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) (SETQ FILE (AR.MAKE.SUMMARY.TEXT.FILE QFORMWINDOW FILE)))) (AR.PROMPT.PRINT QFORMWINDOW T "Wrote " FILE) else (AR.PROMPT.PRINT QFORMWINDOW " ... aborted")))))
)

(AR.MAKE.SUMMARY.FILE
(LAMBDA (QFORMWINDOW FILENAME FIELDS-TO-PRINT) (* ; "Edited 29-Feb-88 19:42 by bvm") (* ;; "Write a summary file from the query in QFORMWINDOW to FILENAME.  FILENAME can also be a stream on a file, such as from OPENIPSTREAM.") (RESETLST (LET* ((*UPPER-CASE-FILE-NAMES*) (STREAM (OR (STREAMP FILENAME) (OPENSTREAM FILENAME (QUOTE OUTPUT) (QUOTE NEW))))) (RESETSAVE NIL (LIST (QUOTE CLOSE-AND-MAYBE-DELETE) STREAM)) (AR.PROMPT.PRINT QFORMWINDOW T "Writing " (FULLNAME STREAM) "...") (AR.PRINT.SUMMARY QFORMWINDOW STREAM FIELDS-TO-PRINT) (AR.PROMPT.PRINT QFORMWINDOW " done.") (FULLNAME STREAM))))
)

(AR.MAKE.SUMMARY.TEXT.FILE
(LAMBDA (QFORMWINDOW FILENAME) (* ; "Edited 20-Jul-88 18:48 by bvm") (LET ((*UPPER-CASE-FILE-NAMES* NIL)) (CL:WITH-OPEN-FILE (S FILENAME :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (AR.PRINT.SUMMARY QFORMWINDOW S) (FULLNAME S))))
)

(AR.QFORM.SUMMARY.TEDIT
(LAMBDA (QFORMWINDOW) (* ; "Edited  4-Aug-88 13:02 by bvm") (if (AR.QFORM.SUMMARIZE.CHECK QFORMWINDOW) then (LET* ((STREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (FONT (FONTCREATE (QUOTE GACHA) 8)) (FIELDS (OR AR.TEDIT.FIELDS AR.SUMMARY.FIELDS)) (WINDOW (CREATEW (GETBOXREGION (WIDTHIFWINDOW (TIMES (CHARWIDTH (CHARCODE X) FONT) (+ (for PAIR in FIELDS sum (* ; "Count column width plus 2 spaces between columns") (+ 2 (CADR PAIR))) 9))) 220) (CONCAT AR.IDENTIFICATION.STRING " Summary")))) (WINDOWPROP WINDOW (QUOTE ICONFN) (FUNCTION TEXTICON)) (AR.PROMPT.PRINT QFORMWINDOW "Creating summary...") (AR.PRINT.SUMMARY QFORMWINDOW STREAM FIELDS) (AR.PROMPT.PRINT QFORMWINDOW "done.") (TEDIT STREAM WINDOW NIL (BQUOTE (LEAVETTY T FONT (\, FONT) PAGEFORMAT (\, (TEDIT.SINGLE.PAGEFORMAT NIL NIL NIL NIL NIL 48 48 48 48 NIL NIL NIL NIL NIL (QUOTE (LANDSCAPE? T))))))))))
)

(AR.QFORM.SUMMARIZE.CHECK
(LAMBDA (QFORMWINDOW) (* ; "Edited 26-Feb-88 19:37 by bvm") (* ;; "Returns true if there are ars in the browser window, else prints message and returns nil.") (if (WINDOWPROP QFORMWINDOW (QUOTE AR.ENTRIES)) else (AR.PROMPT.PRINT QFORMWINDOW "There are no ARs to summarize") NIL))
)

(AR.OPEN.IP.STREAM
(LAMBDA (FILE DOCUMENT.NAME) (* ; "Edited  1-Aug-88 12:37 by bvm") (* ;; "Opens and returns an IP stream for printing an ar summary.  FILE Is the name given to OPENIMAGESTREAM, which is NIL for the default printer.  DOCUMENT.NAME is optional name to give the document (printer header page)") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (FONT (FONTCREATE (QUOTE (TERMINAL 6)) NIL NIL NIL (QUOTE INTERPRESS))) (REGION (CREATEREGION (fetch (REGION LEFT) of DEFAULTLANDPAGEREGION) (- (fetch (REGION BOTTOM) of DEFAULTLANDPAGEREGION) (IQUOTIENT MICASPERINCH 2)) (fetch (REGION WIDTH) of DEFAULTLANDPAGEREGION) (+ (fetch (REGION HEIGHT) of DEFAULTLANDPAGEREGION) MICASPERINCH))) (STREAM (OPENIMAGESTREAM FILE (QUOTE INTERPRESS) (BQUOTE (LANDSCAPE T REGION (\, REGION) HEADING (\, (PROGN (* ; "Crock.  Make a heading consisting of enough spaces to get page number right justified.  IP code spaces the page number an inch to the right of the heading") (ALLOCSTRING (IQUOTIENT (- (fetch (REGION WIDTH) of REGION) (STRINGWIDTH "Page 999" FONT) MICASPERINCH) (CHARWIDTH (CHARCODE SPACE) FONT)) (CHARCODE SPACE)))) FONTS ((\, FONT))))))) (if DOCUMENT.NAME then (STREAMPROP STREAM (QUOTE PRINTOPTIONS) (LIST* (QUOTE DOCUMENT.NAME) DOCUMENT.NAME (STREAMPROP STREAM (QUOTE PRINTOPTIONS))))) STREAM))
)

(AR.PRINT.PADDED
(LAMBDA (STR STREAM START MAXCHARS PRINTWIDTH) (* ; "Edited 26-Feb-88 18:41 by bvm") (* ;; "Given a string or symbol to print, print characters from it, starting with char START, going for up to MAXCHARS.  If PRINTWIDTH is supplied, it must be at least MAXCHARS, and will result in padding the field with blanks on the right, as needed.  If there were still chars left in the string at the end, returns the offset of the next char to print, else NIL.") (SETQ STREAM (\GETSTREAM STREAM (QUOTE OUTPUT))) (LET (BASE STRLEN STROFF FATP CHARSLEFT START-OFFSET FATP EXCESSP) (if (LITATOM STR) then (SETQ BASE (ffetch (LITATOM PNAMEBASE) of STR)) (SETQ STRLEN (ffetch (PNAMEBASE PNAMELENGTH) of BASE)) (SETQ STROFF 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of STR)) else (OR (STRINGP STR) (SETQ STR (MKSTRING STR))) (SETQ BASE (ffetch (STRINGP XBASE) of STR)) (SETQ STRLEN (ffetch (STRINGP LENGTH) of STR)) (SETQ STROFF (ffetch (STRINGP OFFST) of STR)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of STR))) (SETQ CHARSLEFT (- STRLEN (SUB1 START))) (if (> CHARSLEFT MAXCHARS) then (SETQ EXCESSP T) (SETQ CHARSLEFT MAXCHARS)) (SETQ START-OFFSET (+ (SUB1 START) STROFF)) (for OFFSET from START-OFFSET to (+ START-OFFSET CHARSLEFT -1) do (* ;; "Print the characters") (\OUTCHAR STREAM (\GETBASECHAR FATP BASE OFFSET))) (if PRINTWIDTH then (* ; "Pad to end of field") (SPACES (- PRINTWIDTH CHARSLEFT) STREAM)) (AND EXCESSP (+ START CHARSLEFT))))
)

(AR.IP.FROM.SUMMARY
(LAMBDA (SUMMARYFILE IPFILENAME) (* ; "Edited 25-Feb-88 11:18 by bvm") (* ;; "Given the text file containing a summary, create the corresponding IP file, landscape & in 6 point Terminal.") (RESETLST (LET (TXTSTREAM IPSTREAM) (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ TXTSTREAM (OPENSTREAM SUMMARYFILE (QUOTE INPUT) (QUOTE OLD))))) (RESETSAVE NIL (LIST (QUOTE CLOSEF) (SETQ IPSTREAM (AR.OPEN.IP.STREAM (OR IPFILENAME (PACKFILENAME.STRING (QUOTE EXTENSION) "IP" (QUOTE VERSION) NIL (QUOTE BODY) TXTSTREAM)))))) (from 1 to (GETFILEINFO TXTSTREAM (QUOTE LENGTH)) do (\OUTCHAR IPSTREAM (\BIN TXTSTREAM))) (FULLNAME IPSTREAM))))
)
)
(DEFINEQ

(AR.PRINT.SUMMARY
  [LAMBDA (QFORMWINDOW STREAM FIELDS-TO-PRINT)           (* ; "Edited 15-Jun-90 11:07 by jds")

    (* ;; "Print an AR summary.  List in it the ARs selected in QFORMWINDOW.  Put the summary on STREAM.  Include in the summary all the fields listed in FIELDS-TO-PRINT, or if that's nil, then AR.ENTRY.LIST.PRINT.FIELDS.")

    (* ;; "The FIELDS list is a list of pairs")

    (OR FIELDS-TO-PRINT (SETQ FIELDS-TO-PRINT AR.SUMMARY.FIELDS))
    (WITH.AR.QUERY
     QFORMWINDOW
     (AR.ENSURE.QUERY.FIELDS QFORMWINDOW (MAPCAR FIELDS-TO-PRINT (FUNCTION CAR)))
     (PROG ((ENTRIES (WINDOWPROP QFORMWINDOW 'AR.ENTRIES))
            (SCRATCH (WINDOWPROP QFORMWINDOW 'AR.FORM.SCRATCH.STREAM))
            DESCRS LMAR SPACEWIDTH TEXTP)
           (if (IMAGESTREAMP STREAM)
               then                                      (* ; 
                                                           "We can use more precise positioning")
                     (SETQ LMAR (DSPLEFTMARGIN NIL STREAM))
                     (SETQ SPACEWIDTH (CHARWIDTH (CHARCODE "x")
                                             STREAM))
             else                                        (* ; "Have to laboriously space")
                   (SETQ TEXTP T))
           (LINELENGTH MAX.SMALLP STREAM)
           (printout STREAM "Summary of " |.I1| (LENGTH ENTRIES)
                  " " AR.IDENTIFICATION.STRING "s generated on " (DATE)
                  " from index dated "
                  (GETFILEINFO AR.INDEX.FILE 'CREATIONDATE)
                  T)
           (printout STREAM "Generated with Query Spec: " (WINDOWPROP QFORMWINDOW 
                                                                 'AR.ENTRY.ALIST.QLIST)
                  T)
           (printout STREAM "Sorted by: " (OR (WINDOWPROP QFORMWINDOW 'AR.ENTRY.ALIST.SLIST)
                                              "AR#")
                  T T)
           (AR.PRINT.PADDED "  AR#" STREAM 1 5 (AND TEXTP 7))
           [SETQ DESCRS (for TRIPLE in FIELDS-TO-PRINT
                           bind NAME WIDTH (KNOWN.FIELDS _ (WINDOWPROP QFORMWINDOW 
                                                                      'AR.FIELD.DESCRIPTIONS))
                                 (COLUMN _ 7)
                           collect 

                                 (* ;; 
"Print the header line and compute the field description list.  TRIPLE = (name maxwidth don'tWrap)")

                                 (if (NOT TEXTP)
                                     then (DSPXPOSITION (+ LMAR (TIMES SPACEWIDTH COLUMN))
                                                     STREAM))
                                 (AR.PRINT.PADDED (SETQ NAME (CAR TRIPLE))
                                        STREAM 1 (SETQ WIDTH (CADR TRIPLE))
                                        (AND TEXTP (+ WIDTH 2)))
                                 (add COLUMN WIDTH 2)
                                 (LIST* (CL:POSITION NAME KNOWN.FIELDS :KEY 'CAR)
                                        WIDTH
                                        (CADDR TRIPLE]
           (TERPRI STREAM)
           (TERPRI STREAM)
           (for DATA in ENTRIES bind ENTRY OVERFLOW.DATA FIELD.VALUES COLUMN LINE# 
                                              NSPACES
              do                                         (* ; "Print AR# on first line")
              (PRINTOUT STREAM |.I5| (fetch (ARQUERYDATA ARQ#) of DATA))
              (SETQ LINE# 0)
              (SETQ COLUMN 7)
              (SETQ NSPACES 2)
              (SETQ FIELD.VALUES (fetch (ARQUERYDATA ARQALLFIELDS) of DATA))
              [SETQ OVERFLOW.DATA
               (for D in DESCRS bind WIDTH VALUE collect D
                  when (PROGN (SETQ WIDTH (CADR D))
                                  (SETQ VALUE (CL:NTH (CAR D)
                                                     FIELD.VALUES))
                                  (PROG1 [if (NULL VALUE)
                                             then (add NSPACES WIDTH 2)
                                                   NIL
                                           else          (* ; 
   "Print the field, return T if there's more to print and it's not a field restricted to one line")
                                                 (if (NOT TEXTP)
                                                     then 
                                                             (* ; "Position to the correct column")
                                                           (DSPXPOSITION (+ LMAR (TIMES SPACEWIDTH 
                                                                                        COLUMN))
                                                                  STREAM))
                                                 (AND [AR.PRINT.SUMMARY.FIELD
                                                       STREAM VALUE WIDTH 0 SCRATCH
                                                       (AND TEXTP (PROG1 NSPACES (SETQ NSPACES 2]
                                                      (NOT (CDDR D]
                                         (add COLUMN WIDTH 2]
              (TERPRI STREAM)
              (if AR.SUMMARY.MIN.LINES
                  then

                  (* ;; 
       "OVERFLOW.DATA is the set of descriptors that have more to do.  Let's print some more lines")

                  (while OVERFLOW.DATA bind NEXTOVERFLOW
                     do (add LINE# 1)
                           (SETQ COLUMN (SETQ NSPACES 7))
                           (SETQ NEXTOVERFLOW OVERFLOW.DATA)
                           (for D in DESCRS bind WIDTH
                              do (SETQ WIDTH (CADR D))
                                    (if (NEQ D (CAR NEXTOVERFLOW))
                                        then             (* ; "Not this field")
                                              (add NSPACES WIDTH 2)
                                      else (if (NOT TEXTP)
                                                   then  (* ; "Position to the correct column")
                                                         (DSPXPOSITION (+ LMAR (TIMES SPACEWIDTH 
                                                                                      COLUMN))
                                                                STREAM))
                                            (if (NULL (AR.PRINT.SUMMARY.FIELD
                                                           STREAM
                                                           (CL:NTH (CAR D)
                                                                  FIELD.VALUES)
                                                           WIDTH
                                                           (TIMES LINE# WIDTH)
                                                           SCRATCH
                                                           (AND TEXTP NSPACES)))
                                                then (RPLACA NEXTOVERFLOW NIL))
                                            (if (NULL (SETQ NEXTOVERFLOW (CDR NEXTOVERFLOW)))
                                                then     (* ; "We're thru with this line")
                                                      (RETURN))
                                            (SETQ NSPACES 2))
                                    (add COLUMN WIDTH 2))
                           (TERPRI STREAM)
                           (SETQ OVERFLOW.DATA (DREMOVE NIL OVERFLOW.DATA))
                     finally                             (* ; 
                                                         "Ensure that we have printed enough lines")
                           (RPTQ (- AR.SUMMARY.MIN.LINES LINE# 1)
                                 (TERPRI STREAM])

(AR.PRINT.SUMMARY.FIELD
(LAMBDA (STREAM VALUE WIDTH START SCRATCH NSPACES) (* ; "Edited 26-Feb-88 22:39 by bvm") (* ;; "Print specified VALUE in a field WIDTH wide, starting at offset START in the value (zero for the first line, width*#lines for later lines).  SCRATCH is the scratch stream where strings live.  If we're printing to a plain text stream, NSPACES is the number of spaces required before we start printing.  Returns true if there is more to print after this.") (if (AND NSPACES (NEQ NSPACES 0)) then (* ; "Need to get to starting column first") (SPACES NSPACES STREAM)) (if (LISTP VALUE) then (* ; "String value = (ptr length) stored on scratch stream") (SETFILEPTR SCRATCH (+ (CAR VALUE) START)) (LET ((LEN (- (CADR VALUE) START))) (to (MIN LEN WIDTH) do (\OUTCHAR STREAM (BIN SCRATCH))) (if (> LEN WIDTH) then (* ; "More to do...") T else (if NSPACES then (* ; "Value was shorter than field, so pad to end") (SPACES (- WIDTH LEN) STREAM)) NIL)) else (AR.PRINT.PADDED VALUE STREAM (+ START 1) WIDTH (AND NSPACES WIDTH))))
)
)



(* ; "Evaluating AR queries")

(DEFINEQ

(AR.QUERY
(LAMBDA (QFORMWINDOW QLIST SLIST) (* ; "Edited  1-Aug-88 12:39 by bvm") (* ;; "Given a query window, and a query in the form of a list of items, run the query.") (WITH.AR.QUERY QFORMWINDOW (LET ((BROWSERWINDOW (WINDOWPROP QFORMWINDOW (QUOTE QFORM.ENTRY.WINDOW))) TBROWSER QUERY.ENTRIES DISPLAY.FIELDS INDICES) (if (AND BROWSERWINDOW (SETQ TBROWSER (WINDOWPROP BROWSERWINDOW (QUOTE TABLEBROWSER)))) then (* ; "Remove old items") (TB.REPLACE.ITEMS TBROWSER NIL)) (AR.PROMPT.PRINT QFORMWINDOW T "Searching...") (SETQ INDICES (AR.QUERY.EVAL QFORMWINDOW QLIST)) (if (NULL INDICES) then (AR.PROMPT.PRINT QFORMWINDOW T "No matching ARs found.") (WINDOWPROP QFORMWINDOW (QUOTE AR.ENTRIES) NIL) else (* ; "Sort them and prepare to display them") (AR.PROMPT.PRINT QFORMWINDOW T "Found " (LENGTH INDICES) " ARs. ") (WINDOWPROP QFORMWINDOW (QUOTE AR.FIELD.DESCRIPTIONS) NIL) (WINDOWPROP QFORMWINDOW (QUOTE AR.ENTRIES) (SETQ INDICES (for X in INDICES collect (LIST X)))) (AR.AUGMENT.QUERY.FIELDS QFORMWINDOW (if BROWSERWINDOW then (* ; "Will want to gather these fields for display") (LET ((FIELDS (MAPCAR (SETQ DISPLAY.FIELDS AR.DISPLAY.FIELDS) (FUNCTION CAR)))) (if SLIST then (* ; "Also need these additional fields to sort by") (APPEND FIELDS (CL:SET-DIFFERENCE SLIST FIELDS)) else FIELDS)) else SLIST)) (if (AR.QUERY.SMALLP QFORMWINDOW BROWSERWINDOW INDICES) then (* ; "Small enough to fetch everything at once") (AR.ENSURE.QUERY.DATA QFORMWINDOW T)) (if SLIST then (WINDOWPROP QFORMWINDOW (QUOTE AR.ENTRIES) (SETQ INDICES (AR.SORT.BY QFORMWINDOW INDICES SLIST)))) (WINDOWPROP QFORMWINDOW (QUOTE AR.ENTRY.ALIST.SLIST) SLIST) (WINDOWPROP QFORMWINDOW (QUOTE AR.DISPLAY.FIELDS) DISPLAY.FIELDS) (if BROWSERWINDOW then (* ; "Install these guys in a TableBrowser") (SETQ QUERY.ENTRIES (for ENTRY in INDICES collect (create TABLEITEM TIDATA _ ENTRY))) (if TBROWSER then (TB.REPLACE.ITEMS TBROWSER QUERY.ENTRIES) else (TB.MAKE.BROWSER QUERY.ENTRIES BROWSERWINDOW (LIST (QUOTE PRINTFN) (FUNCTION AR.BROWSER.PRINTFN))))) (AR.PROMPT.PRINT QFORMWINDOW " done.")) (WINDOWPROP QFORMWINDOW (QUOTE AR.ENTRY.ALIST.QLIST) QLIST))))
)

(AR.QUERY.SMALLP
(LAMBDA (QFORMWINDOW BROWSERWINDOW ENTRIES) (* ; "Edited 26-Jul-88 11:20 by bvm") (* ;; "True if query is small enough to be worth fetching all its data en masse.") (* ;; "Current def: true if all entries will fit in window (since then we'll have to fetch all anyway).") (<= (LENGTH ENTRIES) (IQUOTIENT (WINDOWPROP BROWSERWINDOW (QUOTE HEIGHT)) (FONTPROP BROWSERWINDOW (QUOTE HEIGHT)))))
)

(AR.QUERY.EVAL
(LAMBDA (QFORMWINDOW QLIST ANDINDEXES NEGFLG) (* ; "Edited 15-Mar-88 20:23 by bvm") (* ;; "Given a query spec in QLIST, evaluate it and return a list of indices that meet the criteria.  If ANDINDEXES is non-NIL, must AND this query with them.  If NEGFLG is true, want to evaluate (NOT QLIST).") (COND ((NLISTP QLIST) (* ; "The spec wasn't a list, so it isn't valid.") (AR.BAD.QUERY QFORMWINDOW QLIST)) (T (SELECTQ (CAR QLIST) (AND (COND (NEGFLG (AR.QUERY.NAND QFORMWINDOW (CDR QLIST) ANDINDEXES)) (T (AR.QUERY.AND QFORMWINDOW (CDR QLIST) ANDINDEXES)))) (OR (if NEGFLG then (* ; "(NOT (OR x y)) = (AND (NOT x) (NOT y))") (AR.QUERY.AND QFORMWINDOW (CDR QLIST) ANDINDEXES T) else (AR.QUERY.OR QFORMWINDOW (CDR QLIST) ANDINDEXES))) (NOT (if (OR (NULL (CDR QLIST)) (CDDR QLIST)) then (* ; "NOT takes exactly one clause") (AR.BAD.QUERY QFORMWINDOW QLIST) else (AR.QUERY.EVAL QFORMWINDOW (CADR QLIST) ANDINDEXES (NOT NEGFLG)))) (SELECTQ (CADR QLIST) (HAS (* ; "String search") (AR.QUERY.HAS QFORMWINDOW (CAR QLIST) (CADDR QLIST) ANDINDEXES NEGFLG)) (IS (* ; "Enumeration search") (AR.QUERY.IS QFORMWINDOW (CAR QLIST) (CADDR QLIST) ANDINDEXES NEGFLG)) ((> >= < <= = ~=) (AR.QUERY.COMPARE QFORMWINDOW QLIST ANDINDEXES NEGFLG)) (AR.BAD.QUERY QFORMWINDOW QLIST))))))
)

(AR.BAD.QUERY
(LAMBDA (QFORMWINDOW ITEM) (* ; "Edited 25-Feb-88 11:57 by bvm") (AR.PROMPT.PRINT QFORMWINDOW T "Bad Query Spec: " ITEM) (ERROR!))
)

(AR.QUERY.AND
(LAMBDA (QFORMWINDOW CLAUSES ANDINDEXES NEGFLG RECURSIVE-P) (* ; "Edited 21-Jul-88 18:48 by bvm") (* ;; "Compute the intersection of ANDINDEXES with the evaluation of each of CLAUSES.  ANDINDEXES of NIL means T to get this going.  NEGFLG means take negation of each clause") (if (CDR CLAUSES) then (SETQ CLAUSES (AR.QUERY.SORT.CLAUSES QFORMWINDOW CLAUSES NEGFLG))) (if (NULL ANDINDEXES) then (SETQ ANDINDEXES (AR.QUERY.EVAL QFORMWINDOW (pop CLAUSES) NIL NEGFLG))) (for C in CLAUSES while ANDINDEXES do (if (NOT RECURSIVE-P) then (* ; "Give progress report at top level query") (AR.PROMPT.PRINT QFORMWINDOW "(" (LENGTH ANDINDEXES) ") ")) (SETQ ANDINDEXES (AR.QUERY.EVAL QFORMWINDOW C ANDINDEXES NEGFLG)) finally (RETURN ANDINDEXES)))
)

(AR.QUERY.NAND
(LAMBDA (QFORMWINDOW CLAUSES ANDINDEXES) (* ; "Edited 21-Jul-88 15:33 by bvm") (AR.QUERY.COMBINE.RESULT (AR.QUERY.AND QFORMWINDOW CLAUSES NIL NIL T) ANDINDEXES T))
)

(AR.QUERY.SORT.CLAUSES
  [LAMBDA (QFORMWINDOW CLAUSES NEGFLG)                (* ; "Edited 17-Jan-89 19:21 by SYBALSKY")

    (* ;; "Sort CLAUSES into a preferred order for an AND query.  If NEGFLG is true, we'll actually be querying the negation of each clause.")

    (LET
     ((SORT.ORDER (AR.QUERY.SORT.ORDER QFORMWINDOW)))
     [if (for C in CLAUSES thereis (SELECTQ (CAR C)
                                                       ((AND NOT) 
                                                            T)
                                                       NIL))
         then

         (* ;; "First canonicalize any funny clauses")

         (LET*
          ((HEAD (CONS NIL CLAUSES))
           (PREV HEAD)
           (TAIL (CDR PREV))
           C NEWTAIL)
          [while TAIL
             do
             (if (SETQ NEWTAIL
                      (SELECTQ (CAR (SETQ C (CAR TAIL)))
                          (AND                               (* ; "Spread any top-level AND")
                               (NCONC (CDR C)
                                      (CDR TAIL)))
                          (NOT (if (EQ (CAR (LISTP (CADR C)))
                                           'OR)
                                   then                  (* ; 
                                                           "(NOT (OR --)) => (AND (NOT ..) --)")
                                         (NCONC [for CL in (CDADR C)
                                                   collect `(NOT ,CL]
                                                (CDR TAIL))))
                          NIL))
                 then (RPLACD PREV (SETQ TAIL NEWTAIL))
               else (SETQ TAIL (CDR (SETQ PREV TAIL]
          (SETQ CLAUSES (CDR HEAD]

     (* ;; "Assign each clause a value, sort the list numerically, then pull the clauses back out.")

     (MAPCAR (CL:STABLE-SORT (for C in CLAUSES collect (CONS (AR.QUERY.SORT.VALUE
                                                                          C SORT.ORDER NEGFLG)
                                                                         C))
                    (FUNCTION <)
                    :KEY
                    (FUNCTION CAR))
            (FUNCTION CDR])

(AR.QUERY.SORT.ORDER
(LAMBDA (QFORMWINDOW) (* ; "Edited 22-Jul-88 10:57 by bvm") (* ;; "Fetch or compute the sort order for this query window, which is heuristically based on database characteristics.  Value is (enumerated  . strings), where each component is a list of the attributes in order of %"best to query first%", preceded by the length of the list.  We believe that it is best to query enumerated attributes before string attributes (easier search).  Within enumerated attributes it is best to search first on those that divide the space more thoroughly (which we heuristically determine to be inversely related to the number of possible values it takes on).  Within string attributes, it is best to search first for those that take up less space on the file, since that will require fewer file accesses.") (OR (WINDOWPROP QFORMWINDOW (QUOTE AR.QUERY.SORT.ORDER)) (LET (ENUMERATED STRINGS ORDER KEYS) (for SPEC in AR.INDEX.FIELD.SPECS do (* ; "Spec = (field . plist)") (if (SETQ KEYS (LISTGET (CDR SPEC) (QUOTE ENUMERATED.FIELD.KEYLIST))) then (* ; "Judge enumerated fields by the number of possible values") (push ENUMERATED (LIST (LENGTH KEYS) (CAR SPEC))) else (* ; "Judge string fields by how much space they take in the file") (push STRINGS (LIST (- (LISTGET (CDR SPEC) (QUOTE FIELD.END.PTR)) (LISTGET (CDR SPEC) (QUOTE FIELD.BEGIN.PTR))) (CAR SPEC))))) (* ;; "Enumerated fields is better to have large values.  For strings, better to have small values.") (SETQ ORDER (for PAIRS in (LIST (REVERSE (SORT ENUMERATED T)) (SORT STRINGS T)) bind (I _ 0) ORIGI LASTVALUE THISORDER collect (* ; "Process Enumerated, then Strings") (SETQ ORIGI I) (SETQ LASTVALUE NIL) (SETQ THISORDER (for PAIR in PAIRS join (LIST (CADR PAIR) (if (EQ LASTVALUE (SETQ LASTVALUE (CAR PAIR))) then (* ; "Same priority") I else (add I 1))))) (* ; "Finally, tack on the front a number that you can subtract any value from in order to negate the sense of the list") (CONS (+ I ORIGI 1) THISORDER))) (RPLACD ORDER (CADR ORDER)) (WINDOWPROP QFORMWINDOW (QUOTE AR.QUERY.SORT.ORDER) ORDER) ORDER)))
)

(AR.QUERY.SORT.VALUE
(LAMBDA (CLAUSE SORT.ORDER NEGFLG) (* ; "Edited 25-Jul-88 12:02 by bvm") (* ;; "Assign a value to CLAUSE.  Low values mean search for me sooner.") (while (EQ (CAR CLAUSE) (QUOTE NOT)) do (SETQ NEGFLG (NOT NEGFLG)) (SETQ CLAUSE (CADR CLAUSE))) (SELECTQ (CAR CLAUSE) (AND (* ; "Take the minimum of the clauses") (for C in (CDR CLAUSE) bind (RESULT _ 1000) do (SETQ RESULT (MIN RESULT (AR.QUERY.SORT.VALUE C SORT.ORDER NEGFLG))) finally (RETURN RESULT))) (OR (* ; "Take the maximum, since we'll have to query ALL the clauses and take the union") (for C in (CDR CLAUSE) bind (RESULT _ -1) do (SETQ RESULT (MAX RESULT (AR.QUERY.SORT.VALUE C SORT.ORDER NEGFLG))) finally (RETURN RESULT))) (LET* ((OP (CADR CLAUSE)) (ORDER (if (EQ OP (QUOTE HAS)) then (* ; "String search") (CDR SORT.ORDER) else (* ; "Enumerated or maybe a weird one") (if (EQ OP (QUOTE ~=)) then (SETQ NEGFLG (NOT NEGFLG))) (CAR SORT.ORDER))) (V (OR (LISTGET (CDR ORDER) (CAR CLAUSE)) (CAR ORDER)))) (if (AND NEGFLG (NEQ OP (QUOTE HAS))) then (* ;; "Reverse order within this list.  This is only vaguely right, and does nothing to account for relational operators (<= etc).  Don't reverse order for string search ops, since their order is a function of how much file there is to search, which doesn't change when negated.") (- (CAR ORDER) V) else V))))
)

(AR.QUERY.OR
(LAMBDA (QFORMWINDOW CLAUSES ANDINDEXES) (* ; "Edited 10-Mar-88 18:35 by bvm") (* ;; "Take the OR of clauses, ANDed with ANDINDEXES (if non-nil).  Since (AND X (OR Y Z)) = (OR (AND X Y) (AND X Z)), we can just pass ANDINDEXES along to the subqueries") (for C in CLAUSES bind A B do (SETQ B (AR.QUERY.EVAL QFORMWINDOW C ANDINDEXES)) (SETQ A (NCONC (while (AND B A) collect (if (< (CAR B) (CAR A)) then (* ; "B < A, so take B") (pop B) else (* ; "A <= B, so take at least A") (if (NOT (< (CAR A) (CAR B))) then (* ; "A = B, so pop from both") (pop B)) (pop A))) (PROGN (* ; "Plus whichever, if either, is left over") (OR B A)))) finally (RETURN A)))
)

(AR.QUERY.COMBINE.RESULT
(LAMBDA (INDEXES ANDINDEXES NEGFLG) (* ; "Edited 25-Jul-88 15:33 by bvm") (* ;; "Used by query handlers that don't handle ANDINDEXES and NEGFLG as part of their operation already.  If NEGFLG is true, complements INDEXES.  Then if ANDINDEXES is given, intersects the result with ANDINDEXES. ") (if ANDINDEXES then (* ;; "Intersect INDEXES and ANDINDEXES by collecting everything in ANDINDEXES that is also in (or NOT in if NEGFLG) INDEXES, taking advantage of the fact that both lists are in order.") (for I in ANDINDEXES collect I unless (EQ (do (if (NULL INDEXES) then (* ; "No more in INDEXES") (RETURN NIL) elseif (> I (CAR INDEXES)) then (* ; "We've passed by some elements of INDEXES, so throw them out") (SETQ INDEXES (CDR INDEXES)) else (* ; "At this point next element of INDEXES is at least I") (RETURN (if (EQ I (CAR INDEXES)) then (* ; "It's equal to I, so signal true (change EQ to >= if indexes can be as big as 2^16)") (SETQ INDEXES (CDR INDEXES)) T)))) NEGFLG)) elseif NEGFLG then (* ; "Compute the complement of INDEXES") (for I from 0 to AR.MAX.INDEX when (COND ((OR (NULL INDEXES) (< I (CAR INDEXES))) (* ; "Haven't hit the next one in INDEXES.") T) (T (* ; "Omit this one, and pop it off the list.  Since INDEXES is dense and sorted, it must be the case that I = (car indexes)") (OR (EQ I (CAR INDEXES)) (HELP)) (pop INDEXES) NIL)) collect I) else INDEXES))
)
)
(DEFINEQ

(AR.QUERY.IS
(LAMBDA (QFORMWINDOW FIELD.NAME VALUE ANDINDEXES NEGFLG) (* ; "Edited 16-Mar-88 12:25 by bvm") (* ;; "Equality search for enumerated fields.  If ANDINDEXES is supplied, result is AND of them and this search.  NEGFLG means search for those whose field is NOT this value.") (LET* ((FIELD.SPEC (CDR (ASSOC FIELD.NAME AR.INDEX.FIELD.SPECS))) (FIELD.KEYLIST (LISTGET FIELD.SPEC (QUOTE ENUMERATED.FIELD.KEYLIST)))) (if FIELD.KEYLIST then (* ; "An enumerated field") (AR.QUERY.IS.EXACTLY QFORMWINDOW FIELD.NAME (if (NULL VALUE) then 0 elseif (LISTGET FIELD.KEYLIST (if (LITATOM VALUE) then VALUE else (MKATOM VALUE))) else (AR.PROMPT.PRINT QFORMWINDOW T "Unknown value " VALUE " for field: " FIELD.NAME) (ERROR!)) (LISTGET FIELD.SPEC (QUOTE FIELD.BEGIN.PTR)) ANDINDEXES NEGFLG) elseif (NOT (MEMB FIELD.NAME AR.INDEX.FIELD.LIST)) then (AR.PROMPT.PRINT QFORMWINDOW T "Unknown field name: " FIELD.NAME) (ERROR!) elseif (OR (NULL VALUE) (EQ (NCHARS VALUE) 0)) then (* ; "We're willing to search for empty string fields") (AR.QUERY.IS.EMPTY QFORMWINDOW FIELD.NAME ANDINDEXES NEGFLG) else (AR.PROMPT.PRINT QFORMWINDOW T "Can't use IS on non-enumerated field " FIELD.NAME " -- will use HAS") (AR.QUERY.HAS QFORMWINDOW FIELD.NAME VALUE ANDINDEXES NEGFLG))))
)

(AR.QUERY.IS.EXACTLY
(LAMBDA (QFORMWINDOW FIELD.NAME SEARCH.KEY BEGIN ANDINDEXES NEGFLG) (* ; "Edited 25-Jul-88 15:33 by bvm") (* ;; "Searches for ARs whose enumerated FIELD.NAME is exactly SEARCH.KEY, a numeric value we have already figured out.  The values for this field are all stored in consecutive bytes on the file.  Just gobble up the bytes, collecting index when byte matches search key") (AR.PROMPT.PRINT QFORMWINDOW FIELD.NAME " ") (if ANDINDEXES then (* ; "Only look at the specified AR's.") (LET ((LASTINDEX (CAR ANDINDEXES))) (SETFILEPTR AR.INDEX.FILE (+ BEGIN LASTINDEX)) (for INDEX in ANDINDEXES when (PROGN (\INCFILEPTR AR.INDEX.FILE (- INDEX LASTINDEX)) (SETQ LASTINDEX (ADD1 INDEX)) (NEQ (EQ (BIN AR.INDEX.FILE) SEARCH.KEY) NEGFLG)) collect INDEX)) else (SETFILEPTR AR.INDEX.FILE BEGIN) (for INDEX from 0 to AR.MAX.INDEX when (NEQ (EQ (BIN AR.INDEX.FILE) SEARCH.KEY) NEGFLG) collect INDEX)))
)

(AR.QUERY.COMPARE.ENUMERATED
(LAMBDA (QFORMWINDOW CLAUSE ANDINDEXES NEGFLG FIELD.KEYLIST BEGIN) (* ; "Edited 25-Jul-88 15:33 by bvm") (* ;; "Perform a numeric comparison on an enumerated field.  CLAUSE is the query, in form (field.name op value [op value]).  FIELD.KEYLIST is the set of keys and BEGIN is where the field values start in the index file.") (DESTRUCTURING-BIND (OP.HI HI.NUM OP.LO LO.NUM NEGFLG) (AR.QUERY.COMPARE.PARSE QFORMWINDOW CLAUSE NEGFLG (FUNCTION (LAMBDA (VALUE QFORMWINDOW) (* ;; "Turn an enumerated field value into a search key") (if (NULL VALUE) then 0 else (LISTGET FIELD.KEYLIST (if (LITATOM VALUE) then VALUE else (MKATOM VALUE))))))) (* ;; "At this point, OP.HI is one of >, >= or =, HI.NUM is corresponding search key.  Optional Lower bound is in OP.LO & LO.NUM.  This is backwards from the usual comparison parse: from the user's point of view, > really means <, since the %"largest%" key is 0 (nil), largest non-nil key is 1, etc.") (* ;; "The values for this field are all stored in consecutive bytes on the file.  Just gobble up the bytes, collecting index when byte compares properly against search key") (if (EQ OP.HI (QUOTE =)) then (* ; "We already have someone to do this search") (AR.QUERY.IS.EXACTLY QFORMWINDOW (CAR CLAUSE) HI.NUM BEGIN ANDINDEXES NEGFLG) else (LET (KEY LASTINDEX) (AR.PROMPT.PRINT QFORMWINDOW (CAR CLAUSE) " ") (if (EQ OP.HI (QUOTE >)) then (* ; "Exclude the bound") (add HI.NUM -1)) (if (EQ OP.LO (QUOTE <)) then (* ; "Exclude the bound") (add LO.NUM 1)) (if ANDINDEXES then (* ; "Only look at the specified AR's.") (SETFILEPTR AR.INDEX.FILE (+ BEGIN (SETQ LASTINDEX (CAR ANDINDEXES)))) (for INDEX in ANDINDEXES when (PROGN (\INCFILEPTR AR.INDEX.FILE (- INDEX LASTINDEX)) (SETQ LASTINDEX (ADD1 INDEX)) (NEQ (AND (<= (SETQ KEY (BIN AR.INDEX.FILE)) HI.NUM) (OR (NULL LO.NUM) (>= KEY LO.NUM))) NEGFLG)) collect INDEX) else (SETFILEPTR AR.INDEX.FILE BEGIN) (for INDEX from 0 to AR.MAX.INDEX when (NEQ (AND (<= (SETQ KEY (BIN AR.INDEX.FILE)) HI.NUM) (OR (NULL LO.NUM) (>= KEY LO.NUM))) NEGFLG) collect INDEX))))))
)

(AR.QUERY.IS.EMPTY
(LAMBDA (QFORMWINDOW FIELD.NAME ANDINDEXES NEGFLG) (* ; "Edited 25-Jul-88 15:34 by bvm") (* ;; "Query on a non-enumerated field for values that are null") (* ;; "Algorithm: Walk thru the fixed-size entries for each AR, and collect the index when the next guy's field ptr is the same as this one's, i.e., the text length is 0.") (AR.PROMPT.PRINT QFORMWINDOW FIELD.NAME " ") (LET* ((FIELD.SPEC (CDR (ASSOC FIELD.NAME AR.INDEX.FIELD.SPECS))) (OFFSET (LISTGET FIELD.SPEC (QUOTE FIELD.OFFSET))) (N+1.VALUE (PROGN (* ;; "Since the length of an entry is computed by subtracting its pointer from the next entry's pointer, you can only compute the final length by looking at the length of the whole region.  Sure would be nice if the index always had a last ar + 1 entry, instead of using FIELD.END.PTR") (- (LISTGET FIELD.SPEC (QUOTE FIELD.END.PTR)) (LISTGET FIELD.SPEC (QUOTE FIELD.BEGIN.PTR))))) (INCREMENT (- AR.INDEX.ENTRY.SIZE AR.BYTES.PER.PTR)) (STREAM AR.INDEX.FILE) (MAX.INDEX AR.MAX.INDEX)) (if ANDINDEXES then (* ; "Only look at these entries") (for INDEX in ANDINDEXES bind (LASTINDEX _ (PROGN (* ; "Initially position stream as if we had read the first one.") (SETFILEPTR STREAM (+ (AR.ENTRY.PTR.FROM.INDEX (CAR ANDINDEXES) OFFSET) AR.BYTES.PER.PTR)) (CAR ANDINDEXES))) collect INDEX when (PROGN (\INCFILEPTR STREAM (- (TIMES (- INDEX LASTINDEX) AR.INDEX.ENTRY.SIZE) AR.BYTES.PER.PTR)) (EQ (< (\DWIN STREAM) (if (EQ INDEX MAX.INDEX) then N+1.VALUE else (* ; "Read the next value, and note LASTINDEX belonging here") (SETQ LASTINDEX (ADD1 INDEX)) (\INCFILEPTR STREAM INCREMENT) (\DWIN STREAM))) NEGFLG))) else (* ; "Search all ARs.  For this, we optimize by reading each pointer only once.") (for INDEX from 0 bind DONE (LASTPTR _ (PROGN (* ; "Initialize loop by reading the address (offset) of the first AR's field value") (SETFILEPTR STREAM (AR.ENTRY.PTR.FROM.INDEX 0 OFFSET)) (\DWIN STREAM))) until DONE when (PROGN (* ;; "Bump the file pointer to the place where the address (actually, offset) of the next ar's value is stored.  If pointers are the same, value of last AR's field must be null.  Since the pointers are monotonic, we can use < instead of the potentially slower = -- if this < next, then entry is non-null.") (\INCFILEPTR STREAM INCREMENT) (EQ (< LASTPTR (SETQ LASTPTR (if (EQ INDEX MAX.INDEX) then (SETQ DONE T) (* ; "ptr for n+1'st entry computed artificially") N+1.VALUE else (\DWIN STREAM)))) NEGFLG)) collect INDEX))))
)
)
(DEFINEQ

(AR.QUERY.HAS
(LAMBDA (QFORMWINDOW FIELD.NAME SEARCH.STRING ANDINDEXES NEGFLG) (* ; "Edited 25-Jul-88 15:34 by bvm") (* ;; "Find ARs containing SEARCH.STRING in their FIELD.NAME.  If ANDINDEXES is given, search only those ars.  NEGFLG=T means search for ARs NOT containing the string.") (LET* ((FIELD.SPEC (CDR (ASSOC FIELD.NAME AR.INDEX.FIELD.SPECS))) (FIELD.OFFSET (LISTGET FIELD.SPEC (QUOTE FIELD.OFFSET)))) (if (NULL FIELD.OFFSET) then (* ; "Not a variable field") (if (NOT (MEMB FIELD.NAME AR.INDEX.FIELD.LIST)) then (AR.PROMPT.PRINT QFORMWINDOW T "Unknown field name: " FIELD.NAME) (ERROR!) else (AR.PROMPT.PRINT QFORMWINDOW T "Can't use HAS on enumerated field " FIELD.NAME " -- will use IS") (AR.QUERY.IS QFORMWINDOW FIELD.NAME SEARCH.STRING ANDINDEXES NEGFLG)) elseif (OR (NULL SEARCH.STRING) (EQ 0 (NCHARS SEARCH.STRING))) then (* ; "Search for empty field") (AR.QUERY.IS.EMPTY QFORMWINDOW FIELD.NAME ANDINDEXES NEGFLG) else (* ;; "The text of all values of this field for all ARs is stored consecutively.  Search that region of the index for desired string, then translate those file pointers into indices.  If ANDINDEXES is given, can restrict search to a narrower range") (AR.PROMPT.PRINT QFORMWINDOW FIELD.NAME " ") (PROG* ((PATLENGTH (NCHARS SEARCH.STRING)) (BEGIN (LISTGET FIELD.SPEC (QUOTE FIELD.BEGIN.PTR))) (HI.PTR (- (LISTGET FIELD.SPEC (QUOTE FIELD.END.PTR)) BEGIN)) (HI.INDEX (ADD1 AR.MAX.INDEX)) LO.PTR LO.INDEX) (if ANDINDEXES then (if (AR.SPARSE.QUERYP HI.PTR ANDINDEXES) then (* ; "The text to search comes out to less than one per 2 pages, so it's likely to be faster to search the ARs one at a time.") (RETURN (for INDEX in ANDINDEXES as SHAPE in (AR.COLLECT.SHAPES ANDINDEXES FIELD.OFFSET HI.PTR) bind START collect INDEX when (NEQ (AND (NEQ (CADR SHAPE) 0) (FILEPOS SEARCH.STRING AR.INDEX.FILE (SETQ START (+ BEGIN (CAR SHAPE))) (+ START (- (CADR SHAPE) PATLENGTH)) NIL T UPPERCASEARRAY)) NEGFLG)))) (SETQ LO.PTR (AR.ENTRY.VALUE.FROM.INDEX (SETQ LO.INDEX (CAR ANDINDEXES)) FIELD.OFFSET)) (if (NEQ HI.INDEX (SETQ HI.INDEX (ADD1 (CAR (LAST ANDINDEXES))))) then (SETQ HI.PTR (AR.ENTRY.VALUE.FROM.INDEX HI.INDEX FIELD.OFFSET))) else (* ; "Nothing to go on, search everything") (SETQ LO.PTR (SETQ LO.INDEX 0))) (SETFILEPTR AR.INDEX.FILE (+ BEGIN LO.PTR)) (RETURN (AR.QUERY.COMBINE.RESULT (AR.INDICES.FROM.FILEPTRS (bind (LAST.POS _ (- (+ HI.PTR BEGIN) PATLENGTH)) PTR while (SETQ PTR (FFILEPOS SEARCH.STRING AR.INDEX.FILE NIL LAST.POS NIL T UPPERCASEARRAY)) collect (* ; "remember that these pointers are to the filepos AFTER the last char of the match") (- PTR BEGIN)) LO.INDEX HI.INDEX FIELD.OFFSET LO.PTR HI.PTR PATLENGTH) ANDINDEXES NEGFLG))))))
)

(AR.COLLECT.SHAPES
(LAMBDA (INDEXES OFFSET TOTALSIZE) (* ; "Edited 25-Jul-88 15:34 by bvm") (* ;; "For each of INDEXES, collect the offset and length of its OFFSET entry.  TOTALSIZE is the offset of the fictional last+1 entry.") (LET* ((STREAM AR.INDEX.FILE) (MAX.INDEX AR.MAX.INDEX) (INCREMENT (- AR.INDEX.ENTRY.SIZE AR.BYTES.PER.PTR)) (LASTINDEX (PROGN (* ; "Initially position stream as if we had read the first one.") (SETFILEPTR STREAM (+ (AR.ENTRY.PTR.FROM.INDEX (CAR INDEXES) OFFSET) AR.BYTES.PER.PTR)) (CAR INDEXES))) START) (for INDEX in INDEXES collect (\INCFILEPTR STREAM (- (TIMES (- INDEX LASTINDEX) AR.INDEX.ENTRY.SIZE) AR.BYTES.PER.PTR)) (LIST (SETQ START (\DWIN STREAM)) (- (if (EQ INDEX MAX.INDEX) then TOTALSIZE else (* ; "Read the next value, and note LASTINDEX belonging here") (SETQ LASTINDEX (ADD1 INDEX)) (\INCFILEPTR STREAM INCREMENT) (\DWIN STREAM)) START)))))
)

(AR.COLLECT.SIZES
(LAMBDA (LO.INDEX HI.INDEX OFFSET MAX.INDEX TOTALSIZE) (* ; "Edited 21-Mar-88 17:58 by bvm") (* ;; "Collect just the lengths of the OFFSET'th field of ars from LO.INDEX to HI.INDEX") (for INDEX from LO.INDEX to HI.INDEX bind (INCREMENT _ (- AR.INDEX.ENTRY.SIZE AR.BYTES.PER.PTR)) (LASTPTR _ (PROGN (* ; "Initialize loop by reading the address (offset) of the first AR's field value") (AR.ENTRY.VALUE.FROM.INDEX LO.INDEX OFFSET))) (STREAM _ AR.INDEX.FILE) collect (* ;; "Bump the file pointer to the place where the address (actually, offset) of the next ar's value is stored.  ") (\INCFILEPTR STREAM INCREMENT) (- (- LASTPTR (SETQ LASTPTR (if (EQ INDEX MAX.INDEX) then (* ; "ptr for n+1'st entry computed artificially") TOTALSIZE else (\DWIN STREAM)))))))
)

(AR.SPARSE.QUERYP
(LAMBDA (DATALENGTH ANDINDEXES) (* ; "Edited 15-Mar-88 12:53 by bvm") (* ;; "Return true if we believe that a HAS search in a space of DATALENGTH bytes confined to the ars ANDINDEXES is likely to be faster by searching individual ARs than by searching the whole space.") (* ;; "Current heuristic: if there is on average fewer than one AR (of ANDINDEXES) per data page, we'll save file accesses by searching specially.  This is fairly conservative--there are many searches in which we would win even if the average is bigger than 1, just because those references may clump.") (> (FOLDLO DATALENGTH BYTESPERPAGE) (LENGTH ANDINDEXES)))
)

(AR.INDICES.FROM.FILEPTRS
(LAMBDA (FILEPTRS LO.INDEX HI.INDEX FIELD.OFFSET LO.PTR HI.PTR PATLENGTH) (* ; "Edited 17-Mar-88 12:18 by bvm") (* ;; "Perform binary search on the index to compute the index pointers for fields returned from FFILEPOS.  FILEPTRS is a list of pointers to the character after a successful search.  They are known to correspond to indices in [lo.index, hi.index).  Those indices correspond to file pointers LO.PTR and HI.PTR.  PATLENGTH is the length of the pattern, which we need in order to determine whether a candidate file pointer is good, or overlaps two ars.") (PROG ((NUMARS (- HI.INDEX LO.INDEX)) MID.INDEX MID.PTR NEXT.PTR BYTES.PER.INDEX) (if (NULL FILEPTRS) then (RETURN NIL)) (if (EQ NUMARS 0) then (HELP "HI=LO and still have fileptrs to find.")) (SETQ MID.INDEX (if (OR (CDR FILEPTRS) (EQ (SETQ BYTES.PER.INDEX (IQUOTIENT (- HI.PTR LO.PTR) NUMARS)) 0)) then (* ; "Pick the midpoint of the range, and then divide FILEPTRS into those that fall below it, those that match it, and those that fall after it.") (+ LO.INDEX (IQUOTIENT NUMARS 2)) else (* ; "Down to searching for just one element, so try to get closer than just stabbing at the midpoint") (+ LO.INDEX (IMIN (IQUOTIENT (- (CAR FILEPTRS) LO.PTR) BYTES.PER.INDEX) (SUB1 NUMARS))))) (if (EQ (- HI.INDEX MID.INDEX) 1) then (* ; "Next = HI") (SETQ NEXT.PTR HI.PTR)) (if (EQ MID.INDEX LO.INDEX) then (SETQ MID.PTR LO.PTR) else (SETQ MID.PTR (AR.ENTRY.VALUE.FROM.INDEX MID.INDEX FIELD.OFFSET)) (* ; "Fileptr corresponding to MID.INDEX.  This is the largest value a pointer can take and belong to an entry below MID.INDEX") (if (NOT NEXT.PTR) then (* ; "Find start of next entry.  Pointers in (mid, next] belong to MID.INDEX") (SETQ NEXT.PTR (AR.ENTRY.VALUE.NEXT)))) (RETURN (for (TAIL _ FILEPTRS) bind PREV do (* ;; "Search for the midpoint of the list, i.e., the place where all the pointers precededing it are before MID.PTR") (if (NULL TAIL) then (* ; "Everything comes before MID.INDEX") (RETURN (AR.INDICES.FROM.FILEPTRS FILEPTRS LO.INDEX MID.INDEX FIELD.OFFSET LO.PTR MID.PTR PATLENGTH)) elseif (> (CAR TAIL) MID.PTR) then (* ; "Everything before TAIL comes before MID.INDEX") (RETURN (NCONC (if (NULL PREV) then (* ; "Nothing before TAIL") NIL else (RPLACD PREV NIL) (* ; "Snip off prefix") (AR.INDICES.FROM.FILEPTRS FILEPTRS LO.INDEX MID.INDEX FIELD.OFFSET LO.PTR MID.PTR PATLENGTH)) (if (<= (CAR TAIL) (OR NEXT.PTR (SETQ NEXT.PTR (AR.ENTRY.VALUE.FROM.INDEX (ADD1 MID.INDEX) FIELD.OFFSET)))) then (* ; "One or more of these pointers falls in the MID.INDEX range.  Get rid of all of them.") (AND (when (>= (- (pop TAIL) MID.PTR) PATLENGTH) do (* ; "The entire pattern is at or beyond MID.PTR, so it's a legitimate match") (SETQ $$VAL T) repeatwhile (AND TAIL (<= (CAR TAIL) NEXT.PTR))) (LIST MID.INDEX))) (AND TAIL (AR.INDICES.FROM.FILEPTRS TAIL (ADD1 MID.INDEX) HI.INDEX FIELD.OFFSET NEXT.PTR HI.PTR PATLENGTH)))) else (SETQ TAIL (CDR (SETQ PREV TAIL))))))))
)
)
(DEFINEQ

(AR.QUERY.COMPARE
(LAMBDA (QFORMWINDOW CLAUSE ANDINDEXES NEGFLG) (* ; "Edited 16-Mar-88 12:30 by bvm") (* ;; "Comparison search.  If ANDINDEXES is supplied, result is AND of them and this search.  NEGFLG means search for those whose field is NOT this value.") (LET* ((FIELD.NAME (CAR CLAUSE)) (FIELD.SPEC (CDR (ASSOC FIELD.NAME AR.INDEX.FIELD.SPECS))) (FIELD.KEYLIST (LISTGET FIELD.SPEC (QUOTE ENUMERATED.FIELD.KEYLIST))) VALUE) (if FIELD.KEYLIST then (* ; "An enumerated field") (AR.QUERY.COMPARE.ENUMERATED QFORMWINDOW CLAUSE ANDINDEXES NEGFLG FIELD.KEYLIST (LISTGET FIELD.SPEC (QUOTE FIELD.BEGIN.PTR))) elseif (EQ FIELD.NAME (QUOTE Number%:)) then (* ; "Had to check this first, since it's not a stored field name in the ordinary sense") (AR.QUERY.NUMBER QFORMWINDOW CLAUSE ANDINDEXES NEGFLG) elseif (NOT (MEMB FIELD.NAME AR.INDEX.FIELD.LIST)) then (AR.PROMPT.PRINT QFORMWINDOW T "Unknown field name: " FIELD.NAME) (ERROR!) elseif (EQ FIELD.NAME (QUOTE Date%:)) then (AR.QUERY.DATE QFORMWINDOW CLAUSE ANDINDEXES NEGFLG) elseif (STRPOS "Date" FIELD.NAME) then (* ; "Some other kind of date comparison") (AR.QUERY.GENERAL.DATE QFORMWINDOW CLAUSE ANDINDEXES NEGFLG) elseif (AND (FMEMB (CADR CLAUSE) (QUOTE (= ~=))) (OR (NULL (SETQ VALUE (CADDR CLAUSE))) (EQ (NCHARS VALUE) 0))) then (* ; "We're willing to search for empty string fields") (AR.QUERY.IS.EMPTY QFORMWINDOW FIELD.NAME ANDINDEXES (if (EQ (CADR CLAUSE) (QUOTE =)) then NEGFLG else (NOT NEGFLG))) else (AR.PROMPT.PRINT QFORMWINDOW T "Can't use numeric comparison on " FIELD.NAME) (ERROR!))))
)

(AR.QUERY.COMPARE.PARSE
(LAMBDA (QFORMWINDOW CLAUSE NEGFLG VALUEFN) (* ; "Edited 17-Mar-88 12:43 by bvm") (* ;; "Parse a clause of the form (field.name > value1 [< value2]) into a list (op1 lo.num op2 hi.num negflg), where op1 is one of =, > or >=, op2 is nil or one of < or <=, and negflg asks for negation.  The numbers are produced by applying VALUEFN to the args value and QFORMWINDOW, and must be integers.  Operators may be negated in order to assure that there is always a lower bound.  Complains (and aborts) if clause is malformed.") (DESTRUCTURING-BIND (OP1 NUM1 . REST) (CDR CLAUSE) (LET (OP2 NUM2) (if (AND (FIXP (SETQ NUM1 (CL:FUNCALL VALUEFN NUM1 OP1 QFORMWINDOW))) (SELECTQ OP1 ((> >=) (OR (NULL REST) (SELECTQ (SETQ OP2 (pop REST)) ((< <=) (* ; "Ok, is a between in the form > lo < hi") (FIXP (SETQ NUM2 (CL:FUNCALL VALUEFN (pop REST) OP2 QFORMWINDOW)))) NIL))) ((< <=) (* ; "Reverse of above") (if (NULL REST) then (* ; "Have only an upper bound.  Canonicalize to be a lower bound") (SETQ OP1 (SELECTQ OP1 (< (QUOTE >=)) (QUOTE >))) (SETQ NEGFLG (NOT NEGFLG)) (* ; "Reverse op and reverse negator") T else (* ; "Canonicalize to > lo < hi") (SETQ OP2 OP1) (SETQ NUM2 NUM1) (SELECTQ (SETQ OP1 (pop REST)) ((> >=) (FIXP (SETQ NUM1 (CL:FUNCALL VALUEFN (pop REST) OP1 QFORMWINDOW)))) NIL))) (= (* ; "Odd query--here for completeness") T) (~= (SETQ NEGFLG (NOT NEGFLG)) (* ; "Turn into = with reverse sense") (SETQ OP1 (QUOTE =))) NIL) (NULL REST)) then (LIST OP1 NUM1 OP2 NUM2 NEGFLG) else (AR.BAD.QUERY QFORMWINDOW CLAUSE)))))
)

(AR.QUERY.NUMBER
(LAMBDA (QFORMWINDOW CLAUSE ANDINDEXES NEGFLG) (* ; "Edited 16-Mar-88 11:39 by bvm") (DESTRUCTURING-BIND (OP.LO LO.NUM OP.HI HI.NUM NEGFLG) (AR.QUERY.COMPARE.PARSE QFORMWINDOW CLAUSE NEGFLG (FUNCTION CL:IDENTITY)) (PROG (LO.INDEX HI.INDEX EXACT) (if (AND HI.NUM (< HI.NUM LO.NUM)) then (AR.PROMPT.PRINT QFORMWINDOW CLAUSE " specifies a null interval.") (ERROR!)) (AR.PROMPT.PRINT QFORMWINDOW "Number: ") (CL:MULTIPLE-VALUE-SETQ (LO.INDEX EXACT) (AR.INDEX.FROM.NUMBER QFORMWINDOW LO.NUM)) (SELECTQ OP.LO (> (if EXACT then (* ; "Don't want to include LO.INDEX") (add LO.INDEX 1))) (= (RETURN (AR.QUERY.COMBINE.RESULT (AND EXACT (LIST LO.INDEX)) ANDINDEXES NEGFLG))) NIL) (if OP.HI then (CL:MULTIPLE-VALUE-SETQ (HI.INDEX EXACT) (AR.INDEX.FROM.NUMBER QFORMWINDOW HI.NUM LO.INDEX)) (if (OR (EQ OP.HI (QUOTE <)) (NOT EXACT)) then (* ; "Don't want to include HI.INDEX.  Note that if EXACT is false, then the index returned is that of the next highest existing AR, or max.index+1 if out of range") (SETQ HI.INDEX (SUB1 HI.INDEX)))) (RETURN (AR.QUERY.PRODUCE.INDEXES LO.INDEX HI.INDEX ANDINDEXES NEGFLG)))))
)

(AR.QUERY.PRODUCE.INDEXES
(LAMBDA (LO.INDEX HI.INDEX ANDINDEXES NEGFLG) (* ; "Edited 25-Jul-88 15:34 by bvm") (* ;; "Produce all indexes in range [lo,hi] (or its complement if NEGFLG is true) that are in ANDINDEXES (default everything).  HI.INDEX may be NIL.") (if (NULL ANDINDEXES) then (* ; "Nothing to intersect") (if NEGFLG then (NCONC (AR.COLLECT.N 0 (SUB1 LO.INDEX)) (AND HI.INDEX (AR.COLLECT.N (ADD1 HI.INDEX) AR.MAX.INDEX))) else (AR.COLLECT.N LO.INDEX (OR HI.INDEX AR.MAX.INDEX))) else (LET ((TAIL ANDINDEXES) HI.PREV LO.PREV) (while (AND TAIL (< (CAR TAIL) LO.INDEX)) do (SETQ TAIL (CDR (SETQ LO.PREV TAIL)))) (* ; "(CAR TAIL) is first candidate ar") (if HI.INDEX then (SETQ HI.PREV LO.PREV) (while (AND TAIL (<= (CAR TAIL) HI.INDEX)) do (SETQ TAIL (CDR (SETQ HI.PREV TAIL)))) else (SETQ TAIL NIL)) (* ;; "At this point we have LO.PREV => first good ar ... HI.PREV => TAIL") (if NEGFLG then (if LO.PREV then (* ; "Take everything up to LO.PREV concatenated with TAIL") (RPLACD LO.PREV TAIL) (* ; "Snip out middle") ANDINDEXES else (* ; "Just TAIL") TAIL) else (if HI.PREV then (* ; "Snip off tail, take everything after LO.PREV") (RPLACD HI.PREV NIL)) (if LO.PREV then (* ; "Found a lower bound, so take what's after it.  In this case we have always snipped off the too-large segment") (CDR LO.PREV) elseif (OR HI.PREV (NULL HI.INDEX)) then (* ; "First one satisfied lower bound and did not violate upper bound") ANDINDEXES else (* ; "First one was too large") NIL)))))
)

(AR.COLLECT.N
(LAMBDA (LO HI) (* ; "Edited 15-Mar-88 19:19 by bvm") (* ;; "Collect the integers from LO to HI") (for I from LO to HI collect I))
)

(AR.INDEX.FROM.NUMBER
(LAMBDA (QFORMWINDOW NUM LO.HINT HI.HINT) (* ; "Edited 25-Jul-88 15:35 by bvm") (* ;; "Find the index that corresponds to NUM.  If we find the exact number, we return T as a second value, else NIL.  LO.HINT and HI.HINT are optional indexes known to bound the search.") (PROG ((LO.INDEX (OR LO.HINT 0)) (HI.INDEX (OR HI.HINT AR.MAX.INDEX)) BOUND MID.INDEX MID.NUM) (* ;; "We will do binary search over the index table.") (if (>= NUM (SETQ BOUND (AR.ENTRY.VALUE.FROM.INDEX HI.INDEX))) then (* ; "At boundary") (RETURN (if (EQ NUM BOUND) then (* ; "Hit upper bound exactly") (CL:VALUES HI.INDEX T) else (* ; "Greater than the last AR#") (if HI.HINT then (SHOULDNT "AR# greater than upper bound")) (CL:VALUES (ADD1 HI.INDEX) NIL))) elseif (<= NUM (SETQ BOUND (AR.ENTRY.VALUE.FROM.INDEX LO.INDEX))) then (* ; "At boundary") (RETURN (CL:VALUES LO.INDEX (if (EQ NUM BOUND) then (* ; "Hit lower bound exactly") T else (* ; "Greater than the last AR#") (if LO.HINT then (SHOULDNT "AR# less than upper bound")) NIL)))) LP (SETQ MID.INDEX (+ LO.INDEX (IQUOTIENT (- HI.INDEX LO.INDEX) 2))) (if (EQ MID.INDEX LO.INDEX) then (* ; "We made no progress, so return the next higher index") (RETURN (CL:VALUES HI.INDEX NIL))) (if (< NUM (SETQ MID.NUM (AR.ENTRY.VALUE.FROM.INDEX MID.INDEX))) then (* ; "Shot too high") (SETQ HI.INDEX MID.INDEX) elseif (EQ NUM MID.NUM) then (RETURN (CL:VALUES MID.INDEX T)) else (* ; "Shot too low") (SETQ LO.INDEX MID.INDEX)) (GO LP)))
)
)
(DEFINEQ

(AR.QUERY.DATE
(LAMBDA (QFORMWINDOW CLAUSE ANDINDEXES NEGFLG) (* ; "Edited 17-Mar-88 19:41 by bvm") (* ;; "Calculate range of ARs satisfying the date specification.  Assume dates are monotonic") (DESTRUCTURING-BIND (LO.DATE HI.DATE NEGFLG) (AR.QUERY.PARSE.DATES QFORMWINDOW CLAUSE NEGFLG) (LET ((FIELD.SPEC (CDR (ASSOC (CAR CLAUSE) AR.INDEX.FIELD.SPECS)))) (AR.QUERY.PRODUCE.INDEXES (AR.INDEX.FROM.DATE QFORMWINDOW LO.DATE FIELD.SPEC) (AND HI.DATE (AR.INDEX.FROM.DATE QFORMWINDOW HI.DATE FIELD.SPEC T)) ANDINDEXES NEGFLG))))
)

(AR.QUERY.GENERAL.DATE
(LAMBDA (QFORMWINDOW CLAUSE ANDINDEXES NEGFLG) (* ; "Edited 25-Jul-88 15:35 by bvm") (* ;; "Query on a date field where we can't assume dates are monotonic") (DESTRUCTURING-BIND (LO.DATE HI.DATE NEGFLG) (AR.QUERY.PARSE.DATES QFORMWINDOW CLAUSE NEGFLG) (LET* ((FIELD.SPEC (CDR (ASSOC (CAR CLAUSE) AR.INDEX.FIELD.SPECS))) (OFFSET (LISTGET FIELD.SPEC (QUOTE FIELD.OFFSET))) (BEGIN (LISTGET FIELD.SPEC (QUOTE FIELD.BEGIN.PTR))) (TOTALSIZE (- (LISTGET FIELD.SPEC (QUOTE FIELD.END.PTR)) BEGIN)) (STREAM AR.INDEX.FILE) LASTLENGTH STR DT) (if ANDINDEXES then (* ; "Only look at these ARs.  Gather up the shapes all at once, so we can access the file efficiently.") (LET ((SHAPES (AR.COLLECT.SHAPES ANDINDEXES OFFSET TOTALSIZE)) LASTPTR LEN) (* ; "List of (offset length)") (SETFILEPTR STREAM (+ BEGIN (SETQ LASTPTR (CAAR SHAPES)))) (for INDEX in ANDINDEXES as PAIR in SHAPES collect INDEX unless (EQ (AND (if (> (SETQ LEN (CADR PAIR)) 0) then (* ; "Advance to next date and read it in") (\INCFILEPTR STREAM (- (CAR PAIR) LASTPTR)) (if (NEQ LEN LASTLENGTH) then (SETQ STR (ALLOCSTRING (SETQ LASTLENGTH LEN)))) (AIN STR 1 LEN STREAM) (SETQ LASTPTR (+ (CAR PAIR) LEN)) (SETQ DT (IDATE STR))) (> DT LO.DATE) (OR (NULL HI.DATE) (< DT HI.DATE))) NEGFLG))) else (LET ((MAX.INDEX AR.MAX.INDEX)) (for LO.INDEX from 0 to MAX.INDEX by 500 join (for INDEX from LO.INDEX as LEN in (PROG1 (AR.COLLECT.SIZES LO.INDEX (MIN (+ LO.INDEX 499) MAX.INDEX) OFFSET MAX.INDEX TOTALSIZE) (SETFILEPTR STREAM (+ BEGIN (AR.ENTRY.VALUE.FROM.INDEX LO.INDEX OFFSET)))) collect INDEX unless (EQ (AND (if (> LEN 0) then (* ; "No need to advance file pointer in this loop, since all fields are consecutive.") (if (NEQ LEN LASTLENGTH) then (SETQ STR (ALLOCSTRING (SETQ LASTLENGTH LEN)))) (AIN STR 1 LEN STREAM) (SETQ DT (IDATE STR))) (> DT LO.DATE) (OR (NULL HI.DATE) (< DT HI.DATE))) NEGFLG))))))))
)

(AR.QUERY.PARSE.DATES
(LAMBDA (QFORMWINDOW CLAUSE NEGFLG) (* ; "Edited 21-Mar-88 16:35 by bvm") (* ;; "Parse a date query CLAUSE into a list (lo.date hi.date negflg), with hi.date possibly nil.") (DESTRUCTURING-BIND (OP.LO LO.DATE OP.HI HI.DATE NEGFLG) (AR.QUERY.COMPARE.PARSE QFORMWINDOW CLAUSE NEGFLG (FUNCTION (LAMBDA (STR OP QFORMWINDOW) (LET* (TIME YEAR (DT (OR (IDATE STR) (PROGN (* ; "try defaulting the time.  Whether beginning or end of day depends on the comparison operator") (IDATE (CONCAT STR (SETQ TIME (SELECTQ OP ((< >= = ~=) (* ; "Default to beginning of day") " 0:00:00") ((<= >) (* ; "Get end of day") " 23:59:59") (SHOULDNT))))))))) (if (OR DT (if (SETQ DT (IDATE (CONCAT STR " " (CL:MULTIPLE-VALUE-BIND (S M H D O Y) (CL:GET-DECODED-TIME) (SETQ YEAR Y)) TIME))) then (* ; "Succeeded by defaulting the year, too.  If this is in the future, however, make it be last year") (if (AND (> (- DT (IDATE)) (TIMES 60 60 24)) (SETQ DT (IDATE (CONCAT STR " " (SUB1 YEAR) TIME)))) then (AR.PROMPT.PRINT QFORMWINDOW "[ = " (GDATE DT (DATEFORMAT NO.SECONDS)))) DT)) then (SELECTQ OP (<= (* ; "Asked to include this time, so bump by a second to make an exclusive bound") (ADD1 DT)) ((>= =) (SUB1 DT)) DT)))))) (* ;; "Since the code above has already arranged that the dates are exclusive bounds, we don't need to look at the operators at all, except to check for the silly =.") (if (AND HI.DATE (< HI.DATE LO.DATE)) then (AR.PROMPT.PRINT QFORMWINDOW CLAUSE " specifies a null interval.") (ERROR!)) (AR.PROMPT.PRINT QFORMWINDOW (CAR CLAUSE) " ") (LIST LO.DATE (OR HI.DATE (if (EQ OP.LO (QUOTE =)) then (* ; "Shorthand for anytime this day.  Assume user didn't specify the hour.") (+ LO.DATE (CONSTANT (ADD1 (TIMES 60 60 24)))))) NEGFLG)))
)

(AR.INDEX.FROM.DATE
(LAMBDA (QFORMWINDOW DATE FIELD.SPEC UPPER.BOUNDP) (* ; "Edited 25-Jul-88 15:36 by bvm") (* ;; "Find the index whose date value is closest to DATE--if UPPER.BOUNDP then we return the largest index whose date does not exceed DATE, otherwise the smallest index whose date is not less than DATE.  Return NIL if no such index exists.") (PROG ((LO.INDEX 0) (HI.INDEX AR.MAX.INDEX) BOUND MID.INDEX MID.DATE) (* ;; "We will do binary search over the index table.") (until (SETQ BOUND (AR.DATE.FROM.INDEX HI.INDEX FIELD.SPEC)) do (* ; "Just in case we can't find the dates") (SETQ HI.INDEX (SUB1 HI.INDEX))) (if (> DATE (SETQ BOUND (AR.DATE.FROM.INDEX HI.INDEX FIELD.SPEC))) then (* ; "All AR's have dates less than this, so succeed here if we wanted an upper bound") (RETURN (AND UPPER.BOUNDP HI.INDEX))) (until (SETQ BOUND (AR.DATE.FROM.INDEX LO.INDEX FIELD.SPEC)) do (* ; "Just in case we can't find the dates") (SETQ LO.INDEX (ADD1 LO.INDEX))) (if (< DATE (SETQ BOUND (AR.DATE.FROM.INDEX LO.INDEX FIELD.SPEC))) then (* ; "All AR's have dates greater than this, so succeed here if we wanted a lower bound") (RETURN (AND (NOT UPPER.BOUNDP) LO.INDEX))) LP (* ;; "Invariant: desired date is always between the dates of LO.INDEX and HI.INDEX") (SETQ MID.INDEX (+ LO.INDEX (IQUOTIENT (- HI.INDEX LO.INDEX) 2))) (if (EQ MID.INDEX LO.INDEX) then (* ;; "At this point, LO.INDEX = HI.INDEX-1, so return one of them, depending on which side we want the date.") (RETURN (if UPPER.BOUNDP then LO.INDEX else HI.INDEX))) NEWDATE (if (NULL (SETQ MID.DATE (AR.DATE.FROM.INDEX MID.INDEX FIELD.SPEC))) then (* ; "Grumble, a dateless AR.  This ought not happen") (if (EQ (add MID.INDEX 1) HI.INDEX) then (* ; "No ar's between original mid and hi have dates, so just lower hi to mid and loop") (SETQ HI.INDEX (+ LO.INDEX (IQUOTIENT (- HI.INDEX LO.INDEX) 2))) (GO LP) else (GO NEWDATE))) (if (< DATE MID.DATE) then (* ; "Shot too high") (SETQ HI.INDEX MID.INDEX) else (* ; "Shot too low") (SETQ LO.INDEX MID.INDEX)) (GO LP)))
)

(AR.DATE.FROM.INDEX
(LAMBDA (INDEX FIELD.SPEC) (* ; "Edited 25-Jul-88 15:36 by bvm") (LET* ((START (AR.ENTRY.VALUE.FROM.INDEX INDEX (LISTGET FIELD.SPEC (QUOTE FIELD.OFFSET)))) (LENGTH (- (if (EQ INDEX AR.MAX.INDEX) then (- (LISTGET FIELD.SPEC (QUOTE FIELD.END.PTR)) (LISTGET FIELD.SPEC (QUOTE FIELD.BEGIN.PTR))) else (AR.ENTRY.VALUE.NEXT)) START)) STR DT) (if (NEQ LENGTH 0) then (SETFILEPTR AR.INDEX.FILE (+ START (LISTGET FIELD.SPEC (QUOTE FIELD.BEGIN.PTR)))) (AIN (SETQ STR (ALLOCSTRING LENGTH)) 1 LENGTH AR.INDEX.FILE) (if (AND (SETQ DT (IDATE STR)) (> DT 0)) then (* ; "Insist that dates be reasonable.  Thus we ignore ARs submitted on machines whose clocks were reset to zero.  Date 0 is actually in 1969.") DT))))
)
)
(DEFINEQ

(AR.NUMS.FROM.QUERY
  [LAMBDA (QFORMWINDOW)                                  (* ; "Edited 15-Jun-90 11:08 by jds")

    (* ;; "Gather the AR numbers listed in a query window, and return a list of them.  Useful for getting AR numbers into Lisp for further processing.")

    (COND
       ((OR QFORMWINDOW (SETQ QFORMWINDOW (AR.SELECT.WINDOW "Select Query form window")))
        (WITH.AR.QUERY QFORMWINDOW (AR.ENSURE.QUERY.DATA QFORMWINDOW '(Number%:))
               (for ENTRY in (WINDOWPROP QFORMWINDOW 'AR.ENTRIES)
                  collect (fetch (ARQUERYDATA ARQ#) of ENTRY])

(AR.ENTRY.PTR.FROM.INDEX
(LAMBDA (INDEX OFFSET) (* ; "Edited 25-Feb-88 12:40 by bvm") (* ;; "Get file pointer for the OFFSET entry of AR specified by INDEX.  OFFSET defaults to zero, which points at the AR number.") (if OFFSET then (+ (TIMES INDEX AR.INDEX.ENTRY.SIZE) OFFSET AR.INDEX.ENTRY.BEGIN.PTR) else (* ; "Avoid the extra box when OFFSET is zero") (+ (TIMES INDEX AR.INDEX.ENTRY.SIZE) AR.INDEX.ENTRY.BEGIN.PTR)))
)

(AR.ENTRY.VALUE.FROM.INDEX
(LAMBDA (INDEX FIELD.OFFSET) (* ; "Edited 11-Mar-88 18:15 by bvm") (* ;; "Return the 32-bit value stored at OFFSET (default zero, which is the ar #) in INDEX's fixed-size entry.  Leaves file pointer positioned after having read that value, if you care.  (Each INDEX has a table AR.INDEX.ENTRY.SIZE long of 4-byte values.)") (SETFILEPTR AR.INDEX.FILE (if FIELD.OFFSET then (+ (TIMES INDEX AR.INDEX.ENTRY.SIZE) FIELD.OFFSET AR.INDEX.ENTRY.BEGIN.PTR) else (* ; "Avoid the extra box when OFFSET is zero") (+ (TIMES INDEX AR.INDEX.ENTRY.SIZE) AR.INDEX.ENTRY.BEGIN.PTR))) (\DWIN AR.INDEX.FILE))
)

(AR.ENTRY.VALUE.NEXT
(LAMBDA NIL (* ; "Edited 17-Mar-88 12:17 by bvm") (* ;; "Called immediately after a call to AR.ENTRY.VALUE.FROM.INDEX, this returns the value of the next entry.  Index must not have been max.index.") (\INCFILEPTR AR.INDEX.FILE (- AR.INDEX.ENTRY.SIZE AR.BYTES.PER.PTR)) (\DWIN AR.INDEX.FILE))
)

(AR.SELECT.WINDOW
(LAMBDA (PROMPT) (* ; "Edited 23-Feb-88 18:56 by bvm") (* ;; "Prompt user for a window with PROMPT.  Returns the main window associated with window pointed to, or NIL if pointed outside a window") (PROMPTPRINT PROMPT) (CL:UNWIND-PROTECT (LET ((W (WHICHW (GETPOSITION)))) (AND W (MAINWINDOW W))) (CLRPROMPT)))
)
)



(* ; "Patch for nasty bug in \INCFILEPTR")

(DEFINEQ

(AR.INCFILEPTR
  [LAMBDA (STREAM AMOUNT)                                (* ; "Edited 15-Jun-90 11:20 by jds")
    (\CALLME '\PAGED.INCFILEPTR)

    (* ;; "Increment file pointer of stream by AMOUNT, which may be negative.  The only reason this function currently exists is to give fast performance to FFILEPOS -- it avoids the boxing that would occur on large file pointers.")

    (UNINTERRUPTABLY
        (PROG ((NEWOFF (+ (fetch (STREAM COFFSET) of STREAM)
                          AMOUNT))
               (NEWPAGE (fetch (STREAM CPAGE) of STREAM)))

         (* ;; 
       "SETFILEPTR sets CHARPOSITION to zero, but callers of \INCFILEPTR don't care, by fiat")

              (COND
                 ((>= NEWOFF BYTESPERPAGE)                   (* ; "New page")
                  (SETQ NEWPAGE (+ NEWPAGE (fetch (BYTEPTR PAGE) of NEWOFF)))
                  (SETQ NEWOFF (fetch (BYTEPTR OFFSET) of NEWOFF)))
                 [(< NEWOFF 0)                               (* ; "New page going backward")
                  [SETQ NEWPAGE (- NEWPAGE (fetch (BYTEPTR PAGE) of (SETQ NEWOFF
                                                                             (SUB1 (- BYTESPERPAGE 
                                                                                      NEWOFF]
                  (COND
                     ((< NEWPAGE 0)                          (* ; 
                                               "Probably shouldn't happen;  should it be an error?")
                      (SETQ NEWPAGE 0)))
                  (SETQ NEWOFF (SUB1 (- BYTESPERPAGE (fetch (BYTEPTR OFFSET) of NEWOFF]
                 ([COND
                     ((< AMOUNT 0)                           (* ; 
                                      "Backing up, may have to set the eof if we have been writing")
                      (\UPDATEOF STREAM)
                      T)
                     (T                                      (* ; 
                                             "Moving forward, make sure we don't move past the eof")
                        (AND (fetch (STREAM CBUFPTR) of STREAM)
                             (<= NEWOFF (fetch (STREAM CBUFSIZE) of STREAM]
                                                             (* ; "easy case, no page turn")
                  (replace (STREAM COFFSET) of STREAM with NEWOFF)
                                                             (* ; 
                                                           "Just bump COFFSET and we're done")
                  (RETURN))
                 (T                                          (* ; "Moving forward past eof, might as well let this fall thru to general case, since we need to make sure current buffer is released.")
                    ))
              (\UPDATEOF STREAM)
              (\RELEASECPAGE STREAM)
              (replace (STREAM CPAGE) of STREAM with NEWPAGE)
              (replace (STREAM COFFSET) of STREAM with NEWOFF)))])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(AND (CCODEP 'AR.INCFILEPTR (MOVD 'AR.INCFILEPTR '\PAGED.INCFILEPTR NIL T)))
)



(* ;; 
"Set up file names.  We use VARS on AR.INDEX.DEFAULT.FILE.NAME to force it correct in the case where the index is moving.  If user has set it to some disk file for manual caching, make that the cache name"
)


(RPAQ? AR.INDEX.CACHE.FILE.NAME (AND (BOUNDP 'AR.INDEX.DEFAULT.FILE.NAME)
                                         (STRPOS "DSK" (UNPACKFILENAME.STRING 
                                                              AR.INDEX.DEFAULT.FILE.NAME 'HOST)
                                                NIL NIL T NIL UPPERCASEARRAY)
                                         AR.INDEX.DEFAULT.FILE.NAME))

(RPAQ? AR.ALWAYS.CACHE.INDEX :ASK)

(RPAQ AR.INDEX.DEFAULT.FILE.NAME "{AR:MV:Envos}<LispARs>AR.INDEX")

(RPAQQ AR.QFORM.TITLEMENU NIL)

(RPAQQ AR.QFORM.FORMAT (|Query List:| CR |Sort List:| CR))

(RPAQQ AR.QFORM.SPECS
       ((|Query List:| FIELDTYPE STRING FN AR.QFORM.PROMPT.LIST.FN)
        (|Sort List:| FIELDTYPE STRING FN AR.QFORM.PROMPT.LIST.FN)
        (Query FIELDTYPE BUTTON FN AR.QFORM.BUTTONFN FONT ARBUTTONFONT)
        (|Print File:| FIELDTYPE STRING)
        (Print FIELDTYPE BUTTON FN AR.QFORM.BUTTONFN FONT ARBUTTONFONT)
        (|Update List:| FIELDTYPE STRING)
        (Update FIELDTYPE BUTTON FN AR.QFORM.BUTTONFN FONT ARBUTTONFONT)
        (|Print Index Stats| FIELDTYPE BUTTON FN AR.QFORM.BUTTONFN FONT ARBUTTONFONT)
        (Debug FIELDTYPE BUTTON FN AR.QFORM.BUTTONFN FONT ARBUTTONFONT)))

(RPAQQ AR.QFORM.ICON #*(60 110)OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@EMML@@@@@C@L@@@@GGGF@@@@@C@L@@@AMMMML@@@@C@L@@@CGGGGF@@@@C@L@@@MMMMMM@@@@C@L@@AGGGGGG@@@@C@L@@AMMMMMMH@@@C@L@@CGGGGGG@@@@C@L@@AMMMMMML@@@C@L@@CGGGGGGF@@@C@L@@AMMHAMML@@@C@L@@CGF@AGGF@@@C@L@@AML@@MML@@@C@L@@CGD@@GGF@@@C@L@@AML@@EML@@@C@L@@CGF@@GGF@@@C@L@@AML@@EML@@@C@L@@CGF@@GGD@@@C@L@@AML@@MML@@@C@L@@@GD@AGGD@@@C@L@@@EH@AMMH@@@C@L@@@@@@GGG@@@@C@L@@@@@AMMM@@@@C@L@@@@@CGGF@@@@C@L@@@@@EMML@@@@C@L@@@@@GGG@@@@@C@L@@@@@EMM@@@@@C@L@@@@@GGD@@@@@C@L@@@@@EML@@@@@C@L@@@@@GGD@@@@@C@L@@@@@EML@@@@@C@L@@@@@GGD@@@@@C@L@@@@@EML@@@@@C@L@@@@@GGD@@@@@C@L@@@@@EML@@@@@C@L@@@@@GGD@@@@@C@L@@@@@EML@@@@@C@L@@@@@GGD@@@@@C@L@@@@@EML@@@@@C@L@@@@@GGD@@@@@C@L@@@@@EML@@@@@C@L@@@@@GGD@@@@@C@L@@@@@AMH@@@@@C@L@@@@@AG@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@GO@@@@@@C@L@@@@@OGH@@@@@C@L@@@@@MML@@@@@C@L@@CH@OGF@@@@@C@L@@OL@MMN@CN@@C@L@ALL@OGF@CO@@C@L@GHN@MMN@GCH@C@L@N@F@OGF@FAL@C@LCH@F@MMN@F@G@C@LC@@BCOOO@L@CHC@L@@@CGOOOIL@ALC@L@@@CO@@CMH@@NC@L@@@CL@@@O@@@FC@L@@@CH@@@G@@@@C@L@@@O@@@@CH@@@C@L@@@LCOCO@L@@@C@L@@@LGOCOHN@@@C@L@GAHNCCALF@@@C@L@GMHLCC@LF@@@C@L@MOHLCC@LGOL@C@LAHC@LCC@LCON@C@LAHC@LCC@LC@N@C@LC@C@OOCOLC@C@C@LC@C@OOCOLC@C@C@LF@C@LCCG@C@AHC@LF@C@LCCCHC@AHC@LF@C@LCCALC@@LC@LF@CHLCC@LF@@NC@L@@AHLCC@LF@@FC@L@@AHLCC@LF@@FC@L@@@LLCC@LL@@@C@L@AOLLCC@LON@@C@L@AOLLCC@LON@@C@L@AHN@CC@ALF@@C@L@AHF@CC@AHC@@C@L@CHF@CC@AHC@@C@L@C@C@CC@C@AH@C@L@C@CHCC@G@AH@C@L@C@AHCC@F@AH@C@L@B@@N@@AN@AL@C@L@F@@G@@CL@@L@C@L@F@@CNCOH@@N@C@L@N@@AOON@@@F@C@L@L@@@CN@@@@C@C@LAH@@@@@@@@@CHC@LAH@@@@@@@@@ALC@LC@@@@@@@@@@ALC@LF@@@@@@@@@@@NC@LF@@@@@@@@@@@FC@L@@@@@@@@@@@@BC@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@L@@@@@@@@@@@@@C@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@
)

(RPAQQ AR.COMPARISON.OPERATORS (> >= < <= = ~= btwn))

(RPAQ? AR.BROWSER.MENU.ITEMS '(("Display" AR.BROWSER.DISPLAY 
                                          "Display selected AR in a readonly window")
                                   ("Edit" AR.BROWSER.EDIT "Edit selected AR in an AREdit window
 (uses same window as last time unless you select with middle button).")
                                   ("Hardcopy AR(s)" AR.BROWSER.HARDCOPY 
                                        "Make hardcopy of the complete content of the selected AR(s)"
                                          )))

(RPAQ? AR.QUERY.MENU.ITEMS '[("Query" (AR.QFORM.QUERY)
                                        "Search the AR database for ARs matching the Query List")
                                 ("Sort" AR.QFORM.SORT 
                                        "Sort the ARs in the browser window using the new Sort List")
                                 ("Hardcopy Summary" AR.QFORM.SUMMARY 
                        "Print to your default printer a summary of the ARs displayed in the browser"
                                        (SUBITEMS ("Text Summary" AR.QFORM.SUMMARY.TEXT 
                                                 "Make a plain text version of the summary on a file"
                                                         )
                                               ("TEdit Summary" AR.QFORM.SUMMARY.TEDIT 
                                             "Edit (using TEdit) a plain text version of the summary"
                                                      ])

(RPAQ? AR.WHENSELECTEDSHADE 4672)

(RPAQ? AR.DISPLAY.FIELDS '((Status%: 5)
                               (Subject%: 50)
                               (Attn%: 15)
                               (System%: 13)
                               (Subsystem%: 13)))

(RPAQ? AR.SUMMARY.FIELDS
       '((Date%: 9 T)
         (System%: 13 T)
         (Subsystem%: 14)
         (Status%: 10 T)
         (Attn%: 13)
         (Subject%: 55)
         (Priority%: 10)
         (Difficulty%: 10)
         (Impact%: 8)
         (|Problem Type:| 13)))

(RPAQ? AR.TEDIT.FIELDS )

(RPAQ? AR.SUMMARY.MIN.LINES 2)

(RPAQ? AR.CLEANUP.SORT.ORDER '(System%: Subsystem%: Status%: Priority%: Impact%:))

(RPAQ? AR.SORT.EQUIVALENTS '((Status%: (Open Open/Unreleased))))

(ADDTOVAR AR.SORT.SPEC.ITEMS ("Standard Summary Order" [FUNCTION (LAMBDA NIL 
                                                                            AR.CLEANUP.SORT.ORDER]
                                        
                                   "Sort order used by AR Cleanup when producing personal summaries."
                                        ))

(ADDTOVAR AR.QUERY.SPEC.ITEMS ("Status is UnFixed" 
                                         "(OR (Status: >= Open/Unreleased) (Status: = Incomplete))" 
                                         "AR is somehow Open, i.e., not Fixed, Declined or Obsoleted"
                                         )
                                  ("Status is Resolved" 
                                         "(AND (Status: >= Obsolete) (Status: <= Fixed)" 
                                         "AR has been taken care of--Fixed, Declined, etc.")
                                  ("Mandatory" 
           "(AND (Status: >= Open/Unreleased) (Priority: = Absolutely) (Problem%% Type: ~= Feature))"
                                         
                                   "Non-Feature AR has priority Absolutely and is still open somehow"
                                         ))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(TYPERECORD AR.INDEX.DATA (AR.INDEX.FILE AR.INDEX.ENTRY.BEGIN.PTR AR.INDEX.ENTRY.END.PTR 
                                     AR.INDEX.ENTRY.SIZE AR.INDEX.FIELD.SPECS AR.INDEX.FIELD.LIST 
                                     AR.MAX.INDEX))

(RECORD ARQUERYDATA (ARQINDEX ARQCOMPLETE . ARQALLFIELDS)
                        (RECORD ARQALLFIELDS (ARQ# . ARQFIELDS))

                        (* ;; "Data for a single AR in the query browser.")

                        (* ;; "ARQINDEX is the index of the AR")

                        (* ;; "ARQCOMPLETE is true if we have filled in all the fields")

                        (* ;; "ARQ# is the first field, the ar number")

                        (* ;; "ARQFIELDS is the rest of the fields.  Each element is either a value, a (offset length) pair in scratch file, or ? to indicate incompleteness.")

                        )

(RECORD ARINDEXDESCR (ARINAME ARIOFFKEYS ARIBEGIN . ARIEND)

                         (* ;; "Descriptor for a particular index field.")

                         (* ;; "ARINAME is name of field")

                         (* ;; 
                "ARIOFFKEYS is offset for string field, or list of key values for enumerated field")

                         (* ;; "ARIBEGIN & ARIEND are the field BEGIN and END pointers")

                         )
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS AR.QFORM.ICON AR.BROWSER.MENU.ITEMS AR.QUERY.MENU.ITEMS AR.COMPARISON.OPERATORS 
       AR.QFORM.TITLEMENU)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)


(DEFMACRO WITH.AR.QUERY (WINDOW &BODY BODY)
   [LET [(FIELDS (REVERSE (RECORDFIELDNAMES 'AR.INDEX.DATA]

        (* ;; "Establish a context in which the fields of AR.INDEX.DATA from WINDOW can be referred to as variables, even specially.")

        (* ;; "Note: depends on AR.INDEX.DATA being a TYPERECORD and RECORDFIELDNAMES returning the fields in reverse order.  This will need to change if the AR.INDEX.DATA record changes")

        `(WITH.MONITOR (WINDOWPROP ,WINDOW 'AR.INDEX.MONITORLOCK)
             (DESTRUCTURING-BIND ,FIELDS (CDR (WINDOWPROP ,WINDOW 'AR.INDEX.DATA))
                    (DECLARE (SPECVARS ,@FIELDS))
                    (IF (NOT (OPENP AR.INDEX.FILE))
                        THEN (AR.INDEX.FILE.REOPEN ,WINDOW))
                    ,@BODY))])

(DEFMACRO ARSPECGET (SPECS FIELDNAME PROP)
   `(LISTGET (CDR (ASSOC ,FIELDNAME ,SPECS))
           ,PROP))


[CL:PROCLAIM (CONS 'CL:SPECIAL (RECORDFIELDNAMES 'AR.INDEX.DATA]

(CASE DFNFLG
    ((PROP ALLPROP)                                          (* ; 
                               "When I load this file PROP, need to get these defs evaled, grumble")
       [LET ((DFNFLG T))
            (MAPC '(WITH.AR.QUERY ARSPECGET)
                  (FUNCTION (LAMBDA (FN)
                              (CL:EVAL (GETDEF FN 'FUNCTIONS NIL '(NOERROR]))

                                                             (* ; 
           "These aren't ours, but declare them to reduce the warnings from compiler & masterscope")

(CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT DEFAULTLANDPAGEREGION))

(DECLARE%: EVAL@COMPILE 

(RPAQQ AR.BYTES.PER.PTR 4)


(CONSTANTS (AR.BYTES.PER.PTR 4))
)


(FILESLOAD (SOURCE)
       TABLEBROWSERDECLS)
)
(DECLARE%: EVAL@COMPILE DOCOPY 

(CL:PROCLAIM '(CL:SPECIAL AR.INDEX.DEFAULT.FILE.NAME AR.INDEX.CACHE.FILE.NAME AR.ALWAYS.CACHE.INDEX 
                     AR.QFORM.SPECS AR.QFORM.FORMAT AR.WHENSELECTEDSHADE AR.DISPLAY.FIELDS 
                     AR.SUMMARY.MIN.LINES AR.SUMMARY.FIELDS AR.TEDIT.FIELDS AR.QUERY.SPEC.ITEMS 
                     AR.SORT.SPEC.ITEMS AR.SORT.EQUIVALENTS))
)
(PUTPROPS ARQUERY COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (10607 31272 (AR.QFORM.CREATE 10617 . 11329) (AR.QFORM.GROUP.CREATE 11331 . 15068) (
AR.QFORM.GET.DEFAULT.INDEX 15070 . 18208) (AR.QFORM.CREATE.ABORT 18210 . 18397) (AR.QFORM.GDATE 18399
 . 18563) (AR.QUERY.WHENSELECTEDFN 18565 . 18807) (AR.QUERY.CLOSEFN 18809 . 18925) (AR.QUERY.SHRINKFN 
18927 . 19045) (AR.QUERY.CLOSE/SHRINK 19047 . 19933) (AR.QUERY.EXPANDFN 19935 . 20256) (
AR.QFORM.ICONFN 20258 . 20424) (AR.INDEX.OPEN 20426 . 21931) (AR.INDEX.FILE.REOPEN 21933 . 22439) (
AR.INDEX.FILE.CLOSE 22441 . 22735) (AR.QFORM.QUERY 22737 . 22988) (AR.QFORM.BUTTONFN 22990 . 23191) (
AR.GET.QLIST.PROMPT.MENU 23193 . 26822) (AR.QLIST.MENU.COMPARISONS 26824 . 27068) (
AR.QFORM.PROMPT.LIST.FN 27070 . 29603) (AR.QFORM.TITLEMENU 29605 . 29923) (AR.MAKE.COMPARISON.STRING 
29925 . 30113) (AR.GET.BUTTON.FIELD.AS.LIST 30115 . 31270)) (31313 41655 (AR.BROWSER.PRINTFN 31323 . 
33223) (AR#.FROM.ITEM 33225 . 33593) (AR.BROWSER.COMMANDFN 33595 . 34468) (AR.BROWSER.DO.COMMAND 34470
 . 35729) (AR.BROWSER.SELECTED.ARS 35731 . 37312) (AR.BROWSER.DISPLAY 37314 . 38524) (AR.BROWSER.EDIT 
38526 . 41341) (AR.BROWSER.HARDCOPY 41343 . 41653)) (41680 71673 (AR.QFORM.SORT 41690 . 42687) (
AR.SORT.BY 42689 . 47133) (AR.GET.SLIST.PROMPT.MENU 47135 . 48967) (AR.ENSURE.QUERY.FIELDS 48969 . 
49436) (AR.ENSURE.QUERY.DATA 49438 . 58263) (AR.COLLECT.ENTRY.FIELDS 58265 . 62057) (
AR.ENSURY.QUERY.DATA.ITEM 62059 . 67277) (AR.AUGMENT.QUERY.FIELDS 67279 . 70905) (
AR.KEYVALS.FROM.KEYLIST 70907 . 71671)) (71709 78526 (AR.QFORM.SUMMARY 71719 . 72189) (
AR.QFORM.SUMMARY.TEXT 72191 . 73013) (AR.MAKE.SUMMARY.FILE 73015 . 73637) (AR.MAKE.SUMMARY.TEXT.FILE 
73639 . 73901) (AR.QFORM.SUMMARY.TEDIT 73903 . 74803) (AR.QFORM.SUMMARIZE.CHECK 74805 . 75116) (
AR.OPEN.IP.STREAM 75118 . 76420) (AR.PRINT.PADDED 76422 . 77874) (AR.IP.FROM.SUMMARY 77876 . 78524)) (
78527 87630 (AR.PRINT.SUMMARY 78537 . 86584) (AR.PRINT.SUMMARY.FIELD 86586 . 87628)) (87669 100416 (
AR.QUERY 87679 . 89800) (AR.QUERY.SMALLP 89802 . 90212) (AR.QUERY.EVAL 90214 . 91490) (AR.BAD.QUERY 
91492 . 91642) (AR.QUERY.AND 91644 . 92396) (AR.QUERY.NAND 92398 . 92582) (AR.QUERY.SORT.CLAUSES 92584
 . 94910) (AR.QUERY.SORT.ORDER 94912 . 96995) (AR.QUERY.SORT.VALUE 96997 . 98337) (AR.QUERY.OR 98339
 . 99005) (AR.QUERY.COMBINE.RESULT 99007 . 100414)) (100417 107158 (AR.QUERY.IS 100427 . 101688) (
AR.QUERY.IS.EXACTLY 101690 . 102606) (AR.QUERY.COMPARE.ENUMERATED 102608 . 104685) (AR.QUERY.IS.EMPTY 
104687 . 107156)) (107159 115146 (AR.QUERY.HAS 107169 . 109849) (AR.COLLECT.SHAPES 109851 . 110742) (
AR.COLLECT.SIZES 110744 . 111523) (AR.SPARSE.QUERYP 111525 . 112181) (AR.INDICES.FROM.FILEPTRS 112183
 . 115144)) (115147 122504 (AR.QUERY.COMPARE 115157 . 116714) (AR.QUERY.COMPARE.PARSE 116716 . 118261)
 (AR.QUERY.NUMBER 118263 . 119384) (AR.QUERY.PRODUCE.INDEXES 119386 . 120871) (AR.COLLECT.N 120873 . 
121023) (AR.INDEX.FROM.NUMBER 121025 . 122502)) (122505 129440 (AR.QUERY.DATE 122515 . 123045) (
AR.QUERY.GENERAL.DATE 123047 . 124932) (AR.QUERY.PARSE.DATES 124934 . 126683) (AR.INDEX.FROM.DATE 
126685 . 128710) (AR.DATE.FROM.INDEX 128712 . 129438)) (129441 131785 (AR.NUMS.FROM.QUERY 129451 . 
130079) (AR.ENTRY.PTR.FROM.INDEX 130081 . 130506) (AR.ENTRY.VALUE.FROM.INDEX 130508 . 131129) (
AR.ENTRY.VALUE.NEXT 131131 . 131449) (AR.SELECT.WINDOW 131451 . 131783)) (131837 134957 (AR.INCFILEPTR
 131847 . 134955)))))
STOP
\ No newline at end of file
diff --git a/internal/library/ARSREPORT b/internal/library/ARSREPORT
new file mode 100644
index 00000000..db1b2bb6
--- /dev/null
+++ b/internal/library/ARSREPORT
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "15-Jun-90 11:39:57" {DSK}<usr>local>lde>lispcore>internal>library>ARSREPORT.;2 19524  

      changes to%:  (VARS ARSREPORTCOMS)

      previous date%: "23-Mar-87 13:47:08" {DSK}<usr>local>lde>lispcore>internal>library>ARSREPORT.;1
)


(* ; "
Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT ARSREPORTCOMS)

(RPAQQ ARSREPORTCOMS ((FNS AR.REPORT ARS.GET.NUM.LIST ARS.REPORT.DRIVER ARS.REPORT.GEN.AR.LIST 
                               ARS.REPORT.GEN.NEW ARS.REPORT.GET.NUM.LIST ARS.REPORT.GET.TDSINFO 
                               ARS.REPORT.PROCESS.TDSINFO)
                          (VARS ARS.BUG.LASTMONTH.RELEASED.BACKLOG 
                                ARS.BUG.LASTMONTH.UNRELEASED.BACKLOG ARS.FEATURE.LASTMONTH.BACKLOG 
                                ARS.HACKERS ARS.TESTERS)))
(DEFINEQ

(AR.REPORT
  [LAMBDA (START# END# TDS-VERSION-LIST STARTDATE ENDDATE FORMWINDOW SCRATCHDIR)
                                                             (* ; "Edited 23-Mar-87 11:20 by shw:")
          
          (* ;; "Main driver for the monthly AR report.  ")
          
          (* ;; "START# is the starting AR number to report on")
          
          (* ;; "END# is the ending AR# to report on")
          
          (* ;; "TDS-VERSION-LIST is a list of versions of the TDS-PROCESSED file")
          
          (* ;; "STARTDATE is the starting date as a string, e.g. %"16-FEB-87%" or %"12 JAN 96%"")
          
          (* ;; "ENDDATE  is the starting date as a string, e.g. %"16-FEB-87%" or %"12 JAN 96%"")
          
          (* ;; "FORMWINDOW is the MAIN window of an AR (we suggest using WHICHW)")
          
          (* ;; "SCRATCHDIR is a directory/host to use for scratch files.  Defaults to {DSK}.")

    (ARS.REPORT.DRIVER START# END# (for VERSION inside TDS-VERSION-LIST
                                      collect (if (EQ VERSION 'LISPARS.TDS)
                                                  then '{ERIS}<LISPARS>LISPARS.TDS
                                                else (PACKFILENAME 'VERSION VERSION 'BODY 
                                                            "{ERIS}<LISPARS>LISPARS.TDS-PROCESSED")))
           (IDATE (CONCAT STARTDATE " 00:00:00"))
           (IDATE (CONCAT ENDDATE " 00:00:00"))
           FORMWINDOW SCRATCHDIR])

(ARS.GET.NUM.LIST
  [LAMBDA (QFORM)                                            (* ckj " 4-Jun-86 18:25")
    (PROG (NUMS)
          [AR.INDEX.DATA.CONTEXT QFORM (SETQ NUMS (for ALIST in (WINDOWPROP QFORM 'AR.ENTRY.ALIST)
                                                     collect (AR.GET.ENTRY.NUM (CAR ALIST]
          (RETURN NUMS])

(ARS.REPORT.DRIVER
  [LAMBDA (STARTING.NUM ENDING.NUM TDS.LIST STARTDATE ENDDATE FORMWINDOW SCRATCHDIR)
                                                             (* ; "Edited 24-Feb-87 17:23 by jds")
    (SETQ ARS.NEW (ARS.REPORT.GEN.AR.LIST STARTING.NUM ENDING.NUM))
    (SETQ TDS.FEATURES.SERVICED (for X in TDS.LIST collect (ARS.REPORT.PROCESS.TDSINFO (
                                                                               ARS.REPORT.GET.TDSINFO
                                                                                        X)
                                                                  STARTDATE ENDDATE)))
    (SETQ ARS.FEATURES.SERVICED NIL)
    (for X in TDS.FEATURES.SERVICED do (SETQ ARS.FEATURES.SERVICED (APPEND ARS.FEATURES.SERVICED X)))
    (ARS.REPORT.GEN.NEW STARTING.NUM ENDING.NUM ARS.FEATURES.SERVICED FORMWINDOW SCRATCHDIR])

(ARS.REPORT.GEN.AR.LIST
  [LAMBDA (START.NUM END.NUM)                                (* ckj "30-May-86 16:38")
    (SETQ AR.LIST (for X from START.NUM to END.NUM collect X))
    (PROG ((NEXT.NUM START.NUM)
           ARDONEFLG)
          (do (COND
                 ((EQP NEXT.NUM END.NUM)
                  (SETQ ARDONEFLG T)))
              [COND
                 ([NLSETQ (SETQ ARSTREAM (OPENSTREAM (AR.FILENAME NEXT.NUM)
                                                'INPUT
                                                'OLD]
                  (CLOSEF ARSTREAM)
                  (SETQ NEXT.NUM (ADD1 NEXT.NUM)))
                 (T (DREMOVE NEXT.NUM AR.LIST)
                    (SETQ NEXT.NUM (ADD1 NEXT.NUM] until (OR ARDONEFLG))
          (RETURN AR.LIST])

(ARS.REPORT.GEN.NEW
  [LAMBDA (START.NUM END.NUM FORMWINDOW FIXED.LIST)          (* ; "Edited 13-Mar-87 13:26 by shw:")
    (PROG ((REPORT.INDEX '{DSK}REPORT-AR.INDEX)
           TXT REPORTWINDOW AR.QWINDOW ARS.NEW.OPEN ARS.NEW.UNSCREENED ARS.NEW.DECLINED ARS.NEW.FIXED 
           ARS.NEW.SUPERSEDED ARS.NEW.INCOMPLETE ARS.NEW.OBSOLETE ARS.NEW.FEATURE 
           ARS.NEW.UNRELEASED.FEATURE ARS.NEW.UNASSIGNED ARS.NEW.WISH ARS.SERVICED.FEATURES 
           ARS.NEW.TOTAL ARS.OPEN.TOTAL ARS.ABSOLUTELY.TOTAL ARS.SUBMITTED.BETA ARS.SUBMITTED.HACKERS 
           ARS.SUBMITTED.TESTERS)
          (AR.INDEX.CREATE REPORT.INDEX)
          [SETQ AR.QWINDOW (CREATEW '(0 0 200 100]
          (AR.QFORM.GROUP.CREATE REPORT.INDEX AR.QWINDOW)
          (DISMISS 10000)
          (AR.INDEX.UPDATE AR.QWINDOW ARS.NEW)
          (CLOSEW AR.QWINDOW)
          [SETQ AR.QWINDOW (CREATEW '(0 0 200 100]
          (AR.QFORM.CREATE REPORT.INDEX AR.QWINDOW)
          (DISMISS 10000)
          (AR.QUERY AR.QWINDOW '(Status%: IS Open))
          (SETQ ARS.NEW.OPEN (ARS.GET.NUM.LIST AR.QWINDOW))
          (AR.QUERY AR.QWINDOW '(Status%: IS New))
          (SETQ ARS.NEW.UNSCREENED (ARS.GET.NUM.LIST AR.QWINDOW))
          (AR.QUERY AR.QWINDOW '(Status%: IS Declined))
          (SETQ ARS.NEW.DECLINED (ARS.GET.NUM.LIST AR.QWINDOW))
          (AR.QUERY AR.QWINDOW '(Status%: IS Fixed))
          (SETQ ARS.NEW.FIXED (ARS.GET.NUM.LIST AR.QWINDOW))
          (AR.QUERY AR.QWINDOW '(Status%: IS Superseded))
          (SETQ ARS.NEW.SUPERSEDED (ARS.GET.NUM.LIST AR.QWINDOW))
          (AR.QUERY AR.QWINDOW '(Status%: IS Incomplete))
          (SETQ ARS.NEW.INCOMPLETE (ARS.GET.NUM.LIST AR.QWINDOW))
          (AR.QUERY AR.QWINDOW '(Status%: IS Obsolete))
          (SETQ ARS.NEW.OBSOLETE (ARS.GET.NUM.LIST AR.QWINDOW))
          (AR.QUERY AR.QWINDOW '(Status%: IS Wish))
          (SETQ ARS.NEW.WISH (ARS.GET.NUM.LIST AR.QWINDOW))
          (AR.QUERY AR.QWINDOW '(In/By%: HAS BETA))
          (SETQ ARS.SUBMITTED.BETA (ARS.GET.NUM.LIST AR.QWINDOW))
          [AR.QUERY AR.QWINDOW (APPEND '(OR) (for HACKER in ARS.HACKERS
                                                collect (APPEND '(Submitter%: HAS) (LIST HACKER]
          (SETQ ARS.SUBMITTED.HACKERS (ARS.GET.NUM.LIST AR.QWINDOW))
          [AR.QUERY AR.QWINDOW (APPEND '(OR) (for TESTER in ARS.TESTERS
                                                collect (APPEND '(Submitter%: HAS) (LIST TESTER]
          (SETQ ARS.SUBMITTED.TESTERS (ARS.GET.NUM.LIST AR.QWINDOW))
          [AR.QUERY AR.QWINDOW '(AND (OR (Subject%: HAS want)
                                         (|Problem Type:| IS Feature))
                                     (Status%: IS Open]
          (SETQ ARS.NEW.FEATURE (APPEND ARS.NEW.FEATURE (ARS.GET.NUM.LIST AR.QWINDOW)))
          (AR.QUERY AR.QWINDOW '(AND (OR (Subject%: HAS want)
                                         (|Problem Type:| IS Feature))
                                     (Status%: IS New)) (SETQ ARS.NEW.UNRELEASED.FEATURE (
                                                                                     ARS.GET.NUM.LIST
                                                                                          AR.QWINDOW)
                                                         ))
          [AR.QUERY AR.QWINDOW '(AND (Status%: IS Open)
                                     (Attn%: HAS lisp]
          (SETQ ARS.NEW.UNASSIGNED (ARS.GET.NUM.LIST AR.QWINDOW))
          [AR.QUERY AR.QWINDOW '(AND (Status%: IS Open)
                                     (Attn%: IS NIL]
          (SETQ ARS.NEW.UNASSIGNED (APPEND ARS.NEW.UNASSIGNED (ARS.GET.NUM.LIST AR.QWINDOW)))
          (CLOSEW AR.QWINDOW)
          (DELFILE REPORT.INDEX)
          [SETQ AR.QWINDOW (CREATEW '(0 0 200 100]
          (AR.QFORM.GROUP.CREATE REPORT.INDEX AR.QWINDOW)
          (DISMISS 10000)
          (AR.INDEX.UPDATE AR.QWINDOW FIXED.LIST)
          (CLOSEW AR.QWINDOW)
          [SETQ AR.QWINDOW (CREATEW '(0 0 200 100]
          (AR.QFORM.CREATE REPORT.INDEX AR.QWINDOW)
          (DISMISS 10000)
          [AR.QUERY AR.QWINDOW '(OR (Subject%: HAS want)
                                    (|Problem Type:| IS Feature]
          (SETQ ARS.SERVICED.FEATURES (APPEND ARS.SERVICED.FEATURES (ARS.GET.NUM.LIST AR.QWINDOW)))
          [SETQ REPORTWINDOW (CREATEW '(400 0 400 200]
          (CLOSEW AR.QWINDOW)
          (SETQ TXT (OPENTEXTSTREAM "" REPORTWINDOW NIL NIL (LIST 'FONT LAFITEEDITORFONT)))
          (PRINTOUT TXT "FIRST AR OF MONTH:" START.NUM " LAST AR OF MONTH:" END.NUM 
                 " NUMBER OF NEW ARS:" (FLENGTH ARS.NEW)
                 " NUMBER OF ARS ACCEPTED:"
                 (PLUS (FLENGTH ARS.NEW.FIXED)
                       (DIFFERENCE (FLENGTH ARS.NEW.OPEN)
                              (FLENGTH ARS.NEW.FEATURE)))
                 " NUMBER OF ARS REJECTED:"
                 (PLUS (FLENGTH ARS.NEW.DECLINED)
                       (FLENGTH ARS.NEW.SUPERSEDED)
                       (FLENGTH ARS.NEW.INCOMPLETE)
                       (FLENGTH ARS.NEW.OBSOLETE))
                 " NUMBER OF UNSCREENED ARS:"
                 (FLENGTH ARS.NEW.UNSCREENED)
                 " NUMBER OF FEATURE REQUESTS SUBMITTED:"
                 (PLUS (FLENGTH ARS.NEW.FEATURE)
                       (FLENGTH ARS.NEW.WISH))
                 " NUMBER OF UNASSIGNED ARS:"
                 (FLENGTH ARS.NEW.UNASSIGNED)
                 " NUMBER OF FIXED ARS:"
                 (FLENGTH ARS.NEW.FIXED)
                 " NUMBER OF SERVICED FEATURE REQUESTS:"
                 (FLENGTH ARS.SERVICED.FEATURES)
                 T)
          [SETQ AR.QWINDOW (CREATEW '(0 0 200 100]
          (AR.QFORM.CREATE '{ERIS}<LISPARS>AR.INDEX AR.QWINDOW)
          (DISMISS 10000)
          [AR.QUERY AR.QWINDOW '(AND (Status%: IS New)
                                     (NOT (|Problem Type:| IS Feature]
          (SETQ ARS.NEW.TOTAL (ARS.GET.NUM.LIST AR.QWINDOW))
          [AR.QUERY AR.QWINDOW '(AND (Status%: IS Open)
                                     (NOT (|Problem Type:| IS Feature]
          (SETQ ARS.OPEN.TOTAL (ARS.GET.NUM.LIST AR.QWINDOW))
          [AR.QUERY AR.QWINDOW '(AND (Priority%: IS Absolutely)
                                     (OR (Status%: IS New)
                                         (Status%: IS Open]
          (SETQ ARS.ABSOLUTELY.TOTAL (ARS.GET.NUM.LIST AR.QWINDOW))
          (CLOSEW AR.QWINDOW)
          [SETQ FINALREPORTWINDOW (CREATEW '(450 0 400 200]
          (SETQ TXT (OPENTEXTSTREAM "" FINALREPORTWINDOW NIL NIL (LIST 'FONT LAFITEEDITORFONT)))
          [PRINTOUT TXT T T .TAB 30 ">>month<< Action Request Data Base Report" T T 
                 ">>lastmonth<< Unreleased Backlog:" .TAB 40 ARS.BUG.LASTMONTH.UNRELEASED.BACKLOG T 
                 ">>lastmonth<< Released Backlog:" .TAB 40 ARS.BUG.LASTMONTH.RELEASED.BACKLOG T 
                 ">>month<< Submissions:" .TAB 40 (IDIFFERENCE END.NUM START.NUM)
                 T "Rejected:" .TAB 40 (PLUS (FLENGTH ARS.NEW.DECLINED)
                                             (FLENGTH ARS.NEW.SUPERSEDED)
                                             (FLENGTH ARS.NEW.INCOMPLETE)
                                             (FLENGTH ARS.NEW.OBSOLETE))
                 T "Feature Requests:" .TAB 40 (PLUS (FLENGTH ARS.NEW.UNRELEASED.FEATURE)
                                                     (FLENGTH ARS.NEW.FEATURE))
                 T "Fixed:" .TAB 40 (FLENGTH ARS.NEW.FIXED)
                 T "Submitted by Beta Test sites:" .TAB 40 (FLENGTH ARS.SUBMITTED.BETA)
                 T "Submitted by Development:" .TAB 40 (FLENGTH ARS.SUBMITTED.HACKERS)
                 T "Submitted by Testing:" .TAB 40 (FLENGTH ARS.SUBMITTED.TESTERS)
                 T "Total (Open/New) ARs marked Absolutely:" .TAB 40 (FLENGTH ARS.ABSOLUTELY.TOTAL)
                 T "Total Open (Released) ARs:" .TAB 40 (FLENGTH ARS.OPEN.TOTAL)
                 T "Total New (Unreleased) ARs" .TAB 40 (FLENGTH ARS.NEW.TOTAL)
                 T T T T .TAB 30 ">>month<< Feature Request Report" T T 
                 ">>lastmonth<< Features Backlog:" .TAB 40 ARS.FEATURE.LASTMONTH.BACKLOG T 
                 "Feature Requests Submitted:" .TAB 40 (PLUS (FLENGTH ARS.NEW.UNRELEASED.FEATURE)
                                                             (FLENGTH ARS.NEW.FEATURE))
                 T "Feature Requests Serviced:" .TAB 40 (FLENGTH ARS.SERVICED.FEATURES)
                 T ">>month<< Features Backlog:" .TAB 40 (PLUS ARS.FEATURE.LASTMONTH.BACKLOG
                                                               (IDIFFERENCE (PLUS (FLENGTH 
                                                                           ARS.NEW.UNRELEASED.FEATURE
                                                                                         )
                                                                                  (FLENGTH 
                                                                                      ARS.NEW.FEATURE
                                                                                         ))
                                                                      (FLENGTH ARS.SERVICED.FEATURES]
          [SETQ ARS.BUG.LASTMONTH.RELEASED.BACKLOG (PLUS ARS.BUG.LASTMONTH.RELEASED.BACKLOG
                                                         (IDIFFERENCE (FLENGTH ARS.NEW.OPEN)
                                                                (FLENGTH ARS.NEW.FEATURE]
          (SETQ ARS.FEATURE.LASTMONTH.BACKLOG (PLUS ARS.FEATURE.LASTMONTH.BACKLOG
                                                    (IDIFFERENCE (PLUS (FLENGTH ARS.NEW.FEATURE)
                                                                       (FLENGTH ARS.NEW.WISH))
                                                           (FLENGTH ARS.SERVICED.FEATURES])

(ARS.REPORT.GET.NUM.LIST
  [LAMBDA (QFORM)                                            (* ckj "30-May-86 16:33")
    (PROG (NUMS)
          [AR.INDEX.DATA.CONTEXT QFORM (SETQ NUMS (for ALIST in (WINDOWPROP QFORM 'AR.ENTRY.ALIST)
                                                     collect (AR.GET.ENTRY.NUM (CAR ALIST]
          (RETURN NUMS])

(ARS.REPORT.GET.TDSINFO
  [LAMBDA (FILENAME)                                         (* ; "Edited  3-Feb-87 16:14 by shw:")
    (PROG ((FILE (OPENSTREAM FILENAME 'INPUT 'OLD))
           TDSLIST)
          (SETQ TDSLIST (while (FILEPOS "  --  " FILE NIL NIL NIL T) bind ARLIST
                           when [LISTP (SETQ ARLIST (PROGN (READ FILE FILERDTBL] collect ARLIST))
          (CLOSEF FILE)
          (RETURN TDSLIST])

(ARS.REPORT.PROCESS.TDSINFO
  [LAMBDA (TDSLIST TDS.STARTDATE TDS.ENDDATE)                (* edited%: "24-Jul-86 17:13")
    (PROG (TDSTEMP TXT ARS.OLD.FEATURE ARS.OLD.FIXED ARS.OLD.SERVICED ARS.OLD.SUPERSEDED 
                 ARS.OLD.OBSOLETE ARS.OLD.DECLINED ARS.OLD.INCOMPLETE)
          (SETQ TDSTEMP (for X in TDSLIST when (NOT (FMEMB 'SUBMIT X)) collect (CDR X)))
          (SETQ TDSTEMP (for X in TDSTEMP when [AND (LEQ TDS.STARTDATE (IDATE (CONCAT (CADADR X)
                                                                                     " 00:00:00")))
                                                    (GREATERP TDS.ENDDATE (IDATE (CONCAT (CADADR
                                                                                          X)
                                                                                        " 00:00:00"]
                           collect X))
          (SETQ TDSTEMP (for X in TDSTEMP when (NOT (MEMB (CAR X)
                                                          ARS.NEW)) collect X))
          (SORT TDSTEMP T)
          (for X in TDSTEMP do (COND
                                  [(STRPOS "->Feature" X)
                                   (SETQ ARS.OLD.FEATURE (APPEND ARS.OLD.FEATURE (LIST (CAR X]
                                  [(STRPOS "Wish->Fixed" X)
                                   (SETQ ARS.OLD.SERVICED (APPEND ARS.OLD.SERVICED
                                                                 (LIST (CAR X]
                                  [(STRPOS "->Fixed" X)
                                   (SETQ ARS.OLD.FIXED (APPEND ARS.OLD.FIXED (LIST (CAR X]
                                  [(STRPOS "->Superseded" X)
                                   (SETQ ARS.OLD.SUPERSEDED (APPEND ARS.OLD.SUPERSEDED
                                                                   (LIST (CAR X]
                                  [(STRPOS "->Obsolete" X)
                                   (SETQ ARS.OLD.OBSOLETE (APPEND ARS.OLD.OBSOLETE
                                                                 (LIST (CAR X]
                                  [(STRPOS "->Declined" X)
                                   (SETQ ARS.OLD.DECLINED (APPEND ARS.OLD.DECLINED
                                                                 (LIST (CAR X]
                                  [(STRPOS "->Incomplete" X)
                                   (SETQ ARS.OLD.INCOMPLETE (APPEND ARS.OLD.INCOMPLETE
                                                                   (LIST (CAR X]
                                  (T)))
          [SETQ REPORTWINDOW (CREATEW '(200 0 400 200]
          (SETQ TXT (OPENTEXTSTREAM "" REPORTWINDOW NIL NIL (LIST 'FONT LAFITEEDITORFONT)))
          (PRINTOUT TXT "STARTING DATE:" TDS.STARTDATE " ENDING DATE:" TDS.ENDDATE 
                 " NUMBER OF FEATURE OLD ARS:" (FLENGTH ARS.OLD.FEATURE)
                 " " ARS.OLD.FEATURE " NUMBER OF FEATURE REQUESTS SERVICED:" (FLENGTH 
                                                                                    ARS.OLD.SERVICED)
                 " " ARS.OLD.SERVICED " NUMBER OF FIXED OLD ARS:" (FLENGTH ARS.OLD.FIXED)
                 " " ARS.OLD.FIXED " NUMBER OF SUPERSEDED OLD ARS:" (FLENGTH ARS.OLD.SUPERSEDED)
                 " " ARS.OLD.SUPERSEDED " NUMBER OF OBSOLETE OLD ARS:" (FLENGTH ARS.OLD.OBSOLETE)
                 " " ARS.OLD.OBSOLETE " NUMBER OF DECLINED OLD ARS:" (FLENGTH ARS.OLD.DECLINED)
                 " " ARS.OLD.DECLINED " NUMBER OF INCOMPLETE OLD ARS:" (FLENGTH ARS.OLD.INCOMPLETE)
                 " " ARS.OLD.INCOMPLETE)
          (RETURN ARS.OLD.FIXED])
)

(RPAQQ ARS.BUG.LASTMONTH.RELEASED.BACKLOG 0)

(RPAQQ ARS.BUG.LASTMONTH.UNRELEASED.BACKLOG 0)

(RPAQQ ARS.FEATURE.LASTMONTH.BACKLOG -4)

(RPAQQ ARS.HACKERS (Bane Burton Charnley Daniels Fischer Jellinek Lanning Masinter Murage Pavel 
                             Pedersen Santosa Shih Sybalsky vanMelle Woz))

(RPAQQ ARS.TESTERS (Blum Cate3 Kelley Lew Rhoades Wilkie))
(PUTPROPS ARSREPORT COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (938 19036 (AR.REPORT 948 . 2498) (ARS.GET.NUM.LIST 2500 . 2860) (ARS.REPORT.DRIVER 2862
 . 3790) (ARS.REPORT.GEN.AR.LIST 3792 . 4595) (ARS.REPORT.GEN.NEW 4597 . 14518) (
ARS.REPORT.GET.NUM.LIST 14520 . 14887) (ARS.REPORT.GET.TDSINFO 14889 . 15343) (
ARS.REPORT.PROCESS.TDSINFO 15345 . 19034)))))
STOP
\ No newline at end of file
diff --git a/internal/library/CALENDARHACKS b/internal/library/CALENDARHACKS
new file mode 100644
index 00000000..53c1c91a
--- /dev/null
+++ b/internal/library/CALENDARHACKS
@@ -0,0 +1,222 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(FILECREATED "23-Mar-94 17:45:59" |{DSK}<king>export>lispcore>internal>library>CALENDARHACKS.;3| 11258  
+
+      |changes| |to:|  (FNS PRINTMONTHIMAGE PRINT-NOTEBOOK-YEAR PRINT-SUMMARY-YEAR PRINT-SCALED-MONTH
+                            )
+
+      |previous| |date:| "15-Jun-90 11:46:01" 
+|{DSK}<king>export>lispcore>internal>library>CALENDARHACKS.;1|)
+
+
+; Copyright (c) 1987, 1990, 1994 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CALENDARHACKSCOMS)
+
+(RPAQQ CALENDARHACKSCOMS
+       (
+        (* |;;| "Hacks for making reminder-book pages for calendars.")
+
+        (FILES CALENDAR)
+        (COMS 
+              (* |;;| "User level functions")
+
+              (FNS PRINT-LAND-MONTH PRINT-LAND-YEAR PRINT-NOTEBOOK-MONTH PRINT-NOTEBOOK-YEAR 
+                   PRINT-SUMMARY-YEAR PRINT-NARROW-MONTH))
+        (COMS 
+              (* |;;| "Internal functions and macros")
+
+              (FNS PRINT-SCALED-MONTH PRINTMONTHIMAGE)
+              (FUNCTIONS CAL-X CAL-Y))))
+
+
+
+(* |;;| "Hacks for making reminder-book pages for calendars.")
+
+
+(FILESLOAD CALENDAR)
+
+
+
+(* |;;| "User level functions")
+
+(DEFINEQ
+
+(PRINT-LAND-MONTH
  (LAMBDA (MONTH YEAR STREAM)                                (* \; "Edited 17-Oct-87 17:45 by jds")
          
          (* |;;| "Print a single month's calendar landscape on letter paper.")

    (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'INTERPRESS '(LANDSCAPE T)))))
         (PRINT-SCALED-MONTH MONTH YEAR 635 635 1.0 1.0 PRINTSTREAM 12 18 6)
         (CLOSEF PRINTSTREAM))))
+
+(PRINT-LAND-YEAR
  (LAMBDA (YEAR STREAM)                                      (* \; "Edited 17-Oct-87 17:49 by jds")
          
          (* |;;| "Print a single month's calendar landscape on letter paper.")

    (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'INTERPRESS '(LANDSCAPE T)))))
         (|for| MONTH |from| 1 |to| 12
            |do| (PRINT-SCALED-MONTH MONTH YEAR 635 635 1.0 1.0 PRINTSTREAM 12 18 6)
                 (DSPNEWPAGE PRINTSTREAM))
         (CLOSEF PRINTSTREAM))))
+
+(PRINT-NOTEBOOK-MONTH
  (LAMBDA (MONTH YEAR STREAM)                                (* \; "Edited 17-Sep-87 21:55 by jds")
          
          (* |;;| "Print a single month's calendar on a half-sheet, suitable for punching and putting in a Time-Design notebook or a 5 1/2 x 8 1/2\" reminder book.")
          
          (* |;;| "If you leave STREAM NIL, you'll get one page on the printer.")

    (PRINT-SCALED-MONTH MONTH YEAR 0 0 0.75 0.6 STREAM)))
+
+(PRINT-NOTEBOOK-YEAR
+  (LAMBDA (YEAR STREAM)                       (* \; "Edited 23-Mar-94 17:22 by turpiN:mv:envos")
+
+    (* |;;| "Print a year's worth of month-calendar pages in half-sheet size.")
+
+    (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'POSTSCRIPT))))
+         (|for| MONTH |from| 1 |to| 12 |do| (PRINT-SCALED-MONTH MONTH YEAR 0
+                                                                   (COND
+                                                                      ((EVENP MONTH 2)
+                                                                       13970)
+                                                                      (T 0))
+                                                                   0.75 0.6 PRINTSTREAM)
+                                                         (COND
+                                                            ((EVENP MONTH 2)
+                                                             (DSPNEWPAGE PRINTSTREAM))))
+         (CLOSEF PRINTSTREAM))))
+
+(PRINT-SUMMARY-YEAR
+  (LAMBDA (YEAR STREAM)                       (* \; "Edited 23-Mar-94 17:36 by turpiN:mv:envos")
+
+    (* |;;| "Print a year's worth of small months on 1 sheet of paper that will fit into a 8.25 x 10.5 format (for Time-Design books).")
+
+    (LET ((PRINTSTREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'POSTSCRIPT '(LANDSCAPE T)))))
+         (|for| MONTH |from| 1 |to| 4 |as| YOFFSET |from| 44500 |by| -14800
+            |do| (PRINT-SCALED-MONTH MONTH YEAR 227 YOFFSET 0.33 0.23 PRINTSTREAM 6 8 6))
+         (|for| MONTH |from| 5 |to| 8 |as| YOFFSET |from| 44500 |by| -14800
+            |do| (PRINT-SCALED-MONTH MONTH YEAR 25427 YOFFSET 0.33 0.23 PRINTSTREAM 6 8 6))
+         (|for| MONTH |from| 9 |to| 12 |as| YOFFSET |from| 44500 |by| -14800
+            |do| (PRINT-SCALED-MONTH MONTH YEAR 50627 YOFFSET 0.33 0.23 PRINTSTREAM 6 8 6))
+         (CLOSEF PRINTSTREAM))))
+
+(PRINT-NARROW-MONTH
  (LAMBDA (MONTH YEAR STREAM)                                (* \; "Edited 17-Sep-87 22:32 by jds")

    (PRINT-SCALED-MONTH MONTH YEAR 0 0 0.45 0.95 STREAM NIL NIL NIL '(LANDSCAPE T))))
+)
+
+
+
+(* |;;| "Internal functions and macros")
+
+(DEFINEQ
+
+(PRINT-SCALED-MONTH
+  (LAMBDA (MONTH YEAR X-OFFSET Y-OFFSET X-SCALE Y-SCALE STREAM DAYSIZE DATESIZE TINYSIZE OPTIONS)
+                                                  (* \; "Edited 23-Mar-94 17:24 by turpiN:mv:envos")
+
+    (* |;;| 
+  "Print a month's calendar on STREAM. MONTH is a number 1-12, Year is the year, 19-- and all.")
+
+    (PROG ((STREAM-EXISTED STREAM)
+           PBIGFONT PCALFONT PLITTLEFONT)
+          (SETCURSOR WAITINGCURSOR)
+          (PRINTOUT PROMPTWINDOW T "Formatting for print...")
+          (SETQ STREAM (OR STREAM (OPENIMAGESTREAM "{LPT}" 'POSTSCRIPT OPTIONS)))
+          (SETQ PBIGFONT (FONTCREATE 'MODERN (OR DAYSIZE 8)
+                                NIL 0 STREAM))
+          (SETQ PCALFONT (FONTCREATE 'CLASSIC (OR DATESIZE 12)
+                                NIL 0 STREAM))
+          (SETQ PLITTLEFONT (FONTCREATE 'MODERN (OR TINYSIZE 6)
+                                   NIL 0 STREAM))
+          (PRINTMONTHIMAGE MONTH YEAR STREAM X-OFFSET Y-OFFSET X-SCALE (OR Y-SCALE X-SCALE)
+                 PBIGFONT PCALFONT PLITTLEFONT)              (* \; "Print horizontal lines")
+          (OR STREAM-EXISTED (CLOSEF STREAM))
+          (PRINTOUT PROMPTWINDOW "done." T)
+          (CURSOR T))))
+
+(PRINTMONTHIMAGE
+  (LAMBDA (MONTH YEAR STREAM XOFFSET YOFFSET X-SCALE Y-SCALE DAYFONT DATEFONT TINYDATEFONT)
+                                                  (* \; "Edited 23-Mar-94 17:42 by turpiN:mv:envos")
+
+    (* |;;| 
+  "Print a month's calendar on STREAM. MONTH is a number 1-12, Year is the year, 19-- and all.")
+
+    (* |;;| 
+  " X-SCALE & XOFFSET,  and Y-SCALE & YOFFSET are used in the CAL-X and CAL-Y macros, resp.")
+
+    (* |;;| "DAYFONT and DATEFONT are used for printing the day names and dates/month title resp.")
+
+    (DSPRESET STREAM)
+    (DSPRIGHTMARGIN 65535 STREAM)
+    (LET ((TITLESTRING (CONCAT (MONTHNAME MONTH)
+                              "   " YEAR)))
+         (MOVETO (- (CAL-X 37559)
+                    (IQUOTIENT (STRINGWIDTH TITLESTRING DATEFONT)
+                           2))
+                (CAL-Y 57827)
+                STREAM))
+    (DSPFONT DATEFONT STREAM)
+    (PRINTOUT STREAM (MONTHNAME MONTH)
+           "   " YEAR)
+    (LET ((DAYLABELS (APPEND (|for| N |from| 1 |to| (DAYOF MONTH 1 YEAR)
+                                |collect| '\ )
+                            (|for| N |from| 1 |to| (DAYSIN MONTH YEAR) |collect|
+                                                                                   N)))
+          (X 1559)
+          (Y 47339)
+          (CT 0))
+         (|for| I |in| DAYLABELS |do| 
+
+                                              (* |;;| "Print blanks up to the first day of the month (to allow for not starting on Sunday), then print the dates.")
+
+                                               (MOVETO (CAL-X X)
+                                                      (CAL-Y Y)
+                                                      STREAM)
+                                               (PRIN1 I STREAM)
+                                               (|add| X 10630)
+                                               (|add| CT 1)
+                                               (COND
+                                                  ((EQ (IREMAINDER CT 7)
+                                                       0)
+                                                   (SETQ X 1701)
+                                                   (|add| Y -8974)))))
+    (|for| X |from| 850 |to| 75968 |by| 10630 |do| 
+
+                                                                    (* |;;| "Print vertical lines")
+
+                                                                    (DRAWLINE (CAL-X X)
+                                                                           (CAL-Y 1701)
+                                                                           (CAL-X X)
+                                                                           (CAL-Y 55559)
+                                                                           40
+                                                                           'PAINT STREAM))
+    (|for| Y |from| 1701 |to| 55559 |by| 8974 |do| 
+
+                                                                    (* |;;| 
+                                                                  "Print horizontal lines")
+
+                                                                    (DRAWLINE (CAL-X 850)
+                                                                           (CAL-Y Y)
+                                                                           (CAL-X 75260)
+                                                                           (CAL-Y Y)
+                                                                           40
+                                                                           'PAINT STREAM))
+    (DSPFONT DAYFONT STREAM)
+    (|for| X |from| 2268 |to| 72567 |by| 10630 |as| D |from| 0 |to|
+                                                                                       6
+       |do| 
+
+             (* |;;| "Print day names")
+
+             (MOVETO (CAL-X X)
+                    (CAL-Y 56126)
+                    STREAM)
+             (PRIN1 (DAYNAME D)
+                    STREAM))
+    (COND
+       ((>= X-SCALE 0.7)
+        (DSPFONT PLITTLEFONT STREAM)
+        (SHOWMONTHSMALL (MONTHPLUS MONTH -1)
+               (MONTHYEARPLUS MONTH YEAR -1)
+               (CAL-X 54709)
+               (CAL-Y 2693)
+               (FTIMES X-SCALE 28.0)
+               STREAM)
+        (SHOWMONTHSMALL (MONTHPLUS MONTH 1)
+               (MONTHYEARPLUS MONTH YEAR 1)
+               (CAL-X 65480)
+               (CAL-Y 2693)
+               (FTIMES X-SCALE 28.0)
+               STREAM)))
+    STREAM))
+)
+
+(DEFMACRO CAL-X (VALUE)
+   `(+ XOFFSET (FIXR (FTIMES ,VALUE X-SCALE))))
+
+(DEFMACRO CAL-Y (VALUE)
+   `(+ YOFFSET (FIXR (FTIMES ,VALUE Y-SCALE))))
+(PUTPROPS CALENDARHACKS COPYRIGHT ("Venue & Xerox Corporation" 1987 1990 1994))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (1199 4926 (PRINT-LAND-MONTH 1209 . 1638) (PRINT-LAND-YEAR 1640 . 2174) (
+PRINT-NOTEBOOK-MONTH 2176 . 2650) (PRINT-NOTEBOOK-YEAR 2652 . 3705) (PRINT-SUMMARY-YEAR 3707 . 4700) (
+PRINT-NARROW-MONTH 4702 . 4924)) (4976 11001 (PRINT-SCALED-MONTH 4986 . 6231) (PRINTMONTHIMAGE 6233 . 
+10999)))))
+STOP
diff --git a/internal/library/CHANGECONTROL b/internal/library/CHANGECONTROL
new file mode 100644
index 00000000..7e719643
--- /dev/null
+++ b/internal/library/CHANGECONTROL
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(filecreated " 9-Aug-90 19:39:26" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>CHANGECONTROL.;5| 13413  

      |changes| |to:|  (vars *change-control-dev-dirs* *change-control-freeze-dirs*)

      |previous| |date:| "27-Jul-90 13:58:46" 
|{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>CHANGECONTROL.;4|)


; Copyright (c) 1987, 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.

(prettycomprint changecontrolcoms)

(rpaqq changecontrolcoms (

(* |;;;| "Automate the process of change-control submission")

                              
                              (* |;;| "Variables which control change control:")

                              
                              (* |;;| "*CHANGE-CONTROL-DEV-DIRS* an AList of item-type -> dir name")

                              
                              (* |;;| "*CHANGE-CONTROL-FREEZE-DIRS* likewise for freeze dirs")

                              
                              (* |;;| 
                        "*CHANGE-CONTROL-CHANGE-TEAMS* names to send change control submissions to")

                              (files comparesources)
                              (vars *change-control-dev-dirs* *change-control-freeze-dirs* 
                                    *change-control-change-teams* 
                                    *change-control-development-leaders* 
                                    *change-control-comparison-functions*)
                              (initvars (*cc-see-details* nil))
                              (fns changecontrol)
                              (commands "cc")))



(* |;;;| "Automate the process of change-control submission")




(* |;;| "Variables which control change control:")




(* |;;| "*CHANGE-CONTROL-DEV-DIRS* an AList of item-type -> dir name")




(* |;;| "*CHANGE-CONTROL-FREEZE-DIRS* likewise for freeze dirs")




(* |;;| "*CHANGE-CONTROL-CHANGE-TEAMS* names to send change control submissions to")


(filesload comparesources)

(rpaqq *change-control-dev-dirs* ((nil . "{pele:mv:Envos}<Medley>1.2>new>")
                                      (source . "{pele:mv:Envos}<Medley>1.2>new>")
                                      (sources . "{pele:mv:Envos}<Medley>1.2>new>")
                                      (:sources . "{pele:mv:Envos}<Medley>1.2>new>")
                                      (:source . "{pele:mv:Envos}<Medley>1.2>new>")
                                      (lib . "{pele:mv:Envos}<Medley>1.2>new>")
                                      (library . "{pele:mv:Envos}<Medley>1.2>new>")
                                      (:lib . "{pele:mv:Envos}<Medley>1.2>new>")
                                      (:library . "{pele:mv:Envos}<Medley>1.2>new>")
                                      (pce . |{ERIS}<Lispcore>internal>Library>|)
                                      (:pce . |{ERIS}<Lispcore>internal>Library>|)
                                      (rooms . |{Pogo:AISNorth}<Rooms>Medley>Sources>|)
                                      (:rooms . |{Pogo:AISNorth}<Rooms>Medley>Sources>|)))

(rpaqq *change-control-freeze-dirs* ((nil . "{pele:mv:envos}<medley>1.2>sources>")
                                         (source . "{pele:mv:envos}<medley>1.2>sources>")
                                         (sources . "{pele:mv:envos}<medley>1.2>sources>")
                                         (:sources . "{pele:mv:envos}<medley>1.2>sources>")
                                         (:source . "{pele:mv:envos}<medley>1.2>sources>")
                                         (lib . "{pele:mv:envos}<medley>1.2>library>")
                                         (library . "{pele:mv:envos}<medley>1.2>library>")
                                         (:lib . "{pele:mv:envos}<medley>1.2>library>")
                                         (:library . "{pele:mv:envos}<medley>1.2>library>")
                                         (rooms . |{Pallas:AISNorth}<Rooms>Medley>Sources>|)
                                         (:rooms . |{Pallas:AISNorth}<Rooms>Medley>Sources>|)))

(rpaqq *change-control-change-teams* ((nil gv "James.envos, Sybalsky.envos" ns 
                                               "MedleyDev:MV:Envos")
                                          (source gv "James.envos, Sybalsky.envos" ns 
                                                 "MedleyDev:MV:Envos")
                                          (sources gv "James.envos, Sybalsky.envos" ns 
                                                 "MedleyDev:MV:Envos")
                                          (:sources gv "James.envos, Sybalsky.envos" ns 
                                                 "MedleyDev:MV:Envos")
                                          (:source gv "James.envos, Sybalsky.envos" ns 
                                                 "MedleyDev:MV:Envos")
                                          (lib gv "James.envos, Sybalsky.envos" ns 
                                               "MedleyDev:MV:Envos")
                                          (library gv "James.envos, Sybalsky.envos" ns 
                                                 "MedleyDev:MV:Envos")
                                          (:lib gv "James.envos, Sybalsky.envos" ns 
                                                "MedleyDev:MV:Envos")
                                          (:library gv "James.envos, Sybalsky.envos" ns 
                                                 "MedleyDev:MV:Envos")
                                          (rooms gv 
                                           "James.envos, Kohlsaat.envos, RClarke.envos, Harada.envos"
                                                 ns 
                               "James:AISNorth, Kohlsaat:AISNorth, RClarke:AISNorth, Harada:AISNorth"
                                                 )
                                          (:rooms gv 
                                           "James.envos, Kohlsaat.envos, RClarke.envos, Harada.envos"
                                                 ns 
                               "James:AISNorth, Kohlsaat:AISNorth, RClarke:AISNorth, Harada:AISNorth"
                                                 )))

(rpaqq *change-control-development-leaders* ((nil gv "Sybalsky.envos" ns "")
                                                 (source gv "Sybalsky.envos" ns "")
                                                 (sources gv "Sybalsky.envos" ns "")
                                                 (:sources gv "Sybalsky.envos" ns "")
                                                 (:source gv "Sybalsky.envos" ns "")
                                                 (lib gv "Sybalsky.envos" ns "")
                                                 (library gv "Sybalsky.envos" ns "")
                                                 (:lib gv "Sybalsky.envos" ns "")
                                                 (:library gv "Sybalsky.envos" ns "")
                                                 (rooms gv "Cutting.pa" ns "Cutting:PARC")
                                                 (:rooms gv "Cutting.pa" ns "Cutting:PARC")))

(rpaqq *change-control-comparison-functions* nil)

(rpaq? *cc-see-details* nil)
(defineq

(CHANGECONTROL
  (LAMBDA (FILES TYPE DETAILS?)                          (* \; "Edited 11-Oct-88 18:44 by jds")

    (* |;;| "Build a change-control message to the change-control team for the files in FILES, which may be a list or a single file name.  The file name may include extensions and version numberts, and the comparison is always against the LATEST version on the freeze directory.")

    (* |;;| "TYPE (presently one of NIL, SOURCE, SOURCES, LIB, LIBRARY), is looked up in several ALists to control what directories the files will be on, and who gets the change-control message..  This permits future extensions to other products.")

    (LET* ((COMFILE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
           (DEVDIR (CDR (ASSOC TYPE *CHANGE-CONTROL-DEV-DIRS*)))
           (FREEZEDIR (CDR (ASSOC TYPE *CHANGE-CONTROL-FREEZE-DIRS*)))
           (CHANGETEAM (LISTGET (CDR (ASSOC TYPE *CHANGE-CONTROL-CHANGE-TEAMS*))
                              (LAFITEMODE)))
           (DEV-LEADER (LISTGET (CDR (ASSOC TYPE *CHANGE-CONTROL-DEVELOPMENT-LEADERS*))
                              (LAFITEMODE)))
           (COMPAREFN (OR (CDR (ASSOC TYPE *CHANGE-CONTROL-COMPARISON-FUNCTIONS*))
                          (FUNCTION COMPARESOURCES)))
           (DATED-FILES (|for| FILE |inside| FILES
                           |join| (LIST (FINDFILE FILE NIL (LIST DEVDIR))
                                            (GETFILEINFO (FINDFILE FILE NIL (LIST DEVDIR))
                                                   'CREATIONDATE))))
           MSG)

          (* |;;| "Do the comparison of latest file with the latest frozen file.")

          (FRESHLINE PROMPTWINDOW)
          (PRINTOUT PROMPTWINDOW "Comparing sources...")
          (|for| FILE |inside| FILES |do| (PRINTOUT PROMPTWINDOW FILE " ")
                                                   (PRINTOUT COMFILE T T 
                                                        "- - - - - - - - - - - - - - - - - - - - - -"
                                                          T T)
                                                   (APPLY* COMPAREFN (PACKFILENAME 'DIRECTORY 
                                                                            FREEZEDIR 'VERSION NIL
                                                                            'BODY FILE)
                                                          (PACKFILENAME 'DIRECTORY DEVDIR
                                                                 'BODY FILE)
                                                          NIL NIL COMFILE))
          (PRINTOUT PROMPTWINDOW "Done." T)

          (* |;;| 
        "Build the change-control detail message that goes to the development project leader:")

          (SETQ MSG (OPENTEXTSTREAM (CONCAT "Subject: Change Control Detail for " FILES "
To: " DEV-LEADER "
cc: " (FULLUSERNAME)
                                           (CL:FORMAT NIL "~%~%Candidate files:~%     ~A (~A)~%"
                                                  (CAR DATED-FILES)
                                                  (CADR DATED-FILES))
                                           (CL:FORMAT NIL "~{~5t~A (~A)~%~}" (CDDR DATED-FILES))
                                           "Comparison of Sources:
")
                           NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT)))
                                                             (* \; "Msg header")
          (TEDIT.SETSEL MSG (|fetch| (TEXTOBJ TEXTLEN) |of| (TEXTOBJ MSG))
                 0
                 'RIGHT NIL T)                               (* \; "Go to the end")
          (SETFILEPTR COMFILE 0)
          (TEDIT.INCLUDE MSG COMFILE)                        (* \; 
                                                           "And append the comparison results")
          (TEDIT.LOOKS MSG '(FAMILY GACHA SIZE 10 WEIGHT MEDIUM SLOPE REGULAR))
          (COND
             ((OR *CC-SEE-DETAILS* DETAILS?)                 (* \; "He wants to see the details")
              (ADD.PROCESS `(\\SENDMESSAGE ',MSG 'NAME 'MESSAGESENDER)))
             (T                                              (* \; 
                                               "Doesn't want to see it; just fire the details off.")
                (LAFITE.SENDMESSAGE MSG)))

          (* |;;| "Now build the message form")

          (SETQ MSG (OPENTEXTSTREAM (CONCAT "Subject: Change Control for " FILES "
To: " CHANGETEAM "
cc: " (FULLUSERNAME)
                                           (CL:FORMAT NIL "~%~%Candidate files:~%     ~A (~A)~%"
                                                  (CAR DATED-FILES)
                                                  (CADR DATED-FILES))
                                           (CL:FORMAT NIL "~{~5t~A (~A)~%~}" (CDDR DATED-FILES))
                                           "
ARs fixed:  >>list of AR numbers<<" "

Changes:  >>Explanation of change<<" 
                            "

Patch File:  >>location of patch file, or note that it's whole-file<<" 
                                    "
Tests: >>location of regression test/script, test case itself," " or ref to AR test case used<<

")
                           NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT)))
                                                             (* \; "Msg header")
          (TEDIT.SETSEL MSG 1 0 'LEFT)
          (TEDIT.NEXT MSG)                                   (* \; 
                                   "Now leave him at the \"explanation\" fill-in, and send it off.")
          (ADD.PROCESS `(\\SENDMESSAGE ',MSG 'NAME 'MESSAGESENDER)))))
)

(defcommand "cc" (file-or-files &optional type) (changecontrol file-or-files (cl:intern
                                                                                  (string type)
                                                                                  'interlisp)))
(putprops changecontrol copyright ("Venue & Xerox Corporation" 1987 1988 1989 1990))
(declare\: dontcopy
  (filemap (nil (7352 13020 (changecontrol 7362 . 13018)))))
stop
\ No newline at end of file
diff --git a/internal/library/COMPAREDIRECTORIES b/internal/library/COMPAREDIRECTORIES
new file mode 100644
index 00000000..23ac3d36
--- /dev/null
+++ b/internal/library/COMPAREDIRECTORIES
@@ -0,0 +1,198 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED " 3-Nov-94 15:44:02" {DSK}<lispcore>internal>library>COMPAREDIRECTORIES.;2 21033  
+
+      changes to%:  (VARS COMPAREDIRECTORIESCOMS)
+                    (FNS COMPARE-DIRECTORIES FIND-UNCOMPILED-FILES)
+
+      previous date%: "15-Jun-90 12:35:57" {DSK}<lispcore>internal>library>COMPAREDIRECTORIES.;1)
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1988, 1990, 1994 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT COMPAREDIRECTORIESCOMS)
+
+(RPAQQ COMPAREDIRECTORIESCOMS (
+                                   (* ;; "Compare the contents to two directories.")
+
+                                   (FNS COMPAREDIRECTORIES COMPAREDIRS.FORMATLINE 
+                                        COMPAREDIRECTORIES.NEWPAGEFN COMPARE-DIRECTORIES)
+                                   
+                                   (* ;; "look for compiled files older than the sources")
+
+                                   (FNS FIND-UNCOMPILED-FILES)))
+
+
+
+(* ;; "Compare the contents to two directories.")
+
+(DEFINEQ
+
+(COMPAREDIRECTORIES
  [LAMBDA (FROMDIR TODIR SHOW=FILESTOO FILEPATTERN LISTINGFILE EXTENSIONSTOAVOID)
                                                             (* ; "Edited 15-Nov-88 17:45 by jds")

    (* ;; "Compare the contents of two directories, e.g., for change-control purposes.  Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other.  If SHOW=FILESTOO, then files that are the same are also listed.  LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.")

    (LET [(LISTINGSTREAM (COND
                            [LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'INTERPRESS '(LANDSCAPE T]
                            (T NIL)))
          (TO-FILES (for FILE in [DIRECTORY (PACKFILENAME.STRING 'BODY TODIR 'BODY
                                                           (OR FILEPATTERN '*.*;]
                       collect (PACKFILENAME.STRING 'VERSION NIL 'BODY FILE]
         (COND
            (LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN)
                   [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT FROMDIR " vs " TODIR)
                                                          (CONCAT "as of " (DATE]
                   (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM)))
         [for FILENAME infiles (PACKFILENAME.STRING 'BODY FROMDIR 'BODY (OR FILEPATTERN
                                                                                    '*.*;))
            bind DT1 DT2 TON SHORT-FROM SHORT-TO
            when [PROGN [SETQ TO-FILES (CL:REMOVE (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL
                                                             'DEVICE NIL 'VERSION NIL 'BODY FILENAME)
                                                  TO-FILES :TEST #'(LAMBDA (ITEM SEQUENCE-ITEM)
                                                                     (STRING-EQUAL
                                                                      ITEM
                                                                      (PACKFILENAME.STRING
                                                                       'HOST NIL 'DIRECTORY NIL
                                                                       'DEVICE NIL 'VERSION NIL
                                                                       'BODY SEQUENCE-ITEM]
                            (NOT (CL:MEMBER (UNPACKFILENAME.STRING FILENAME 'EXTENSION)
                                        EXTENSIONSTOAVOID :TEST #'STRING-EQUAL]
            do (PRINTOUT T FILENAME T)
                  (COND
                     [[SETQ TON (INFILEP (PACKFILENAME.STRING 'DIRECTORY TODIR 'VERSION NIL
                                                'BODY
                                                (SETQ SHORT-FROM (PACKFILENAME.STRING 'HOST NIL
                                                                        'DIRECTORY NIL 'DEVICE NIL
                                                                        'BODY FILENAME]
                      (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'DEVICE NIL
                                            'BODY TON))
                      (COND
                         [[EQUAL (SETQ DT1 (GETFILEINFO FILENAME 'ICREATIONDATE))
                                 (SETQ DT2 (GETFILEINFO TON 'ICREATIONDATE]
                                                             (* ; "same")
                          (COND
                             (SHOW=FILESTOO (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM ""
                                                   (GDATE DT1)
                                                   "=="
                                                   (GDATE DT2)
                                                   SHORT-TO ""]
                         (T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO
                                                                                  FILENAME
                                                                                  'AUTHOR)
                                   (GDATE DT1)
                                   (COND
                                      ((LESSP DT1 DT2)
                                       "<<")
                                      (T ">>"))
                                   (GDATE DT2)
                                   SHORT-TO
                                   (GETFILEINFO TON 'AUTHOR]
                     (T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO
                                                                              FILENAME
                                                                              'AUTHOR)
                               (GETFILEINFO FILENAME 'CREATIONDATE)
                               "**" "" "" ""]
         [bind SHORT-TO DT2 for FILENAME in TO-FILES
            when (NOT (CL:MEMBER (UNPACKFILENAME.STRING FILENAME 'EXTENSION)
                                 EXTENSIONSTOAVOID :TEST #'STRING-EQUAL))
            do (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'DEVICE NIL
                                         'BODY FILENAME))
                  (SETQ DT2 (GETFILEINFO FILENAME 'ICREATIONDATE))
                  (COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**" (GDATE DT2)
                         SHORT-TO
                         (GETFILEINFO FILENAME 'AUTHOR]
         (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM])
+
+(COMPAREDIRS.FORMATLINE
  [LAMBDA (STREAM FROM FROMAUTHOR FDATE COMP TDATE TO TOAUTHOR)
                                                             (* ; "Edited 15-Nov-88 17:40 by jds")

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

    (COND
       (STREAM                                               (* ; 
                                         "It's an interpress stream, where TAB doesn't work right.")
              (LET* [(COMPFONT (FONTCREATE 'MODERN 8 'BOLD NIL 'INTERPRESS))
                     (MAINFONT (FONTCREATE 'MODERN 8 NIL NIL 'INTERPRESS))
                     (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE)
                                        STREAM))
                     (LEFTMARGIN (DSPLEFTMARGIN NIL STREAM))
                     (RIGHTMARGIN (DSPRIGHTMARGIN NIL STREAM))
                     (CENTER (IQUOTIENT (+ LEFTMARGIN RIGHTMARGIN)
                                    2))
                     (COMPWIDTH (IQUOTIENT (IMAX (STRINGWIDTH ">>" COMPFONT)
                                                 (STRINGWIDTH "<<" COMPFONT)
                                                 (STRINGWIDTH "==" COMPFONT)
                                                 (STRINGWIDTH "**" COMPFONT))
                                       2))
                     (LEFTSIDE (- CENTER 353 COMPWIDTH))
                     (RIGHTSIDE (+ CENTER COMPWIDTH 353))
                     (FROM-STRING (COND
                                     (FROM (CL:FORMAT NIL "~A (~A; ~A)" FROM FROMAUTHOR FDATE))
                                     (T "")))
                     (TO-STRING (COND
                                   (TO (CL:FORMAT NIL "~A (~A; ~A)" TO TOAUTHOR TDATE))
                                   (T ""]
                    (DSPFONT COMPFONT STREAM)
                    (DSPXPOSITION (- CENTER (IQUOTIENT (STRINGWIDTH COMP COMPFONT)
                                                   2))
                           STREAM)
                    (PRIN1 COMP STREAM)
                    (DSPFONT MAINFONT STREAM)
                    (DSPXPOSITION (- LEFTSIDE (STRINGWIDTH FROM-STRING MAINFONT))
                           STREAM)
                    (PRIN1 FROM-STRING STREAM)
                    (DSPXPOSITION RIGHTSIDE STREAM)
                    (PRINTOUT STREAM TO-STRING T)))
       (T                                                    (* ; 
                                                           "the display, where TAB does work.")
          (PRINTOUT STREAM FROM (COND
                                   (FROMAUTHOR (CONCAT "(" FROMAUTHOR ")"))
                                   (T ""))
                 45 "[" FDATE "]" 69 COMP 83 "[" TDATE "]" 103 TO (COND
                                                                     (TOAUTHOR (CONCAT "(" TOAUTHOR 
                                                                                      ")"))
                                                                     (T ""))
                 T])
+
+(COMPAREDIRECTORIES.NEWPAGEFN
  [LAMBDA (LISTINGSTREAM)                                (* ; "Edited 15-Nov-88 19:20 by jds")

    (* ;; "Print the new-page headings on a COMPARE-DIRECTORIES page.")

    (LET* ((LEFT (DSPLEFTMARGIN NIL LISTINGSTREAM))
           (RIGHT (DSPRIGHTMARGIN NIL LISTINGSTREAM))
           (TITLEFONT (FONTCREATE 'MODERN 10 'BOLD NIL LISTINGSTREAM))
           (TITLE (STREAMPROP LISTINGSTREAM 'TITLE))
           (HEAD-WIDTH (IQUOTIENT (STRINGWIDTH (CAR TITLE)
                                         TITLEFONT)
                              2))
           (CENTER (IQUOTIENT (+ LEFT RIGHT)
                          2)))
          (DSPFONT TITLEFONT LISTINGSTREAM)
          (MOVETO (- CENTER HEAD-WIDTH)
                 (DSPTOPMARGIN NIL LISTINGSTREAM)
                 LISTINGSTREAM)
          (PRIN1 (CAR TITLE)
                 LISTINGSTREAM)
          (MOVETO (- RIGHT (STRINGWIDTH (CDR TITLE)
                                  TITLEFONT))
                 1270 LISTINGSTREAM)
          (PRIN1 (CDR TITLE)
                 LISTINGSTREAM)
          (MOVETO LEFT [IDIFFERENCE (DSPTOPMARGIN NIL LISTINGSTREAM)
                              (FIXR (FTIMES 1.5 (FONTPROP TITLEFONT 'HEIGHT]
                 LISTINGSTREAM])
+
+(COMPARE-DIRECTORIES
+  [LAMBDA (FROMDIR TODIR SHOW=FILESTOO FILEPATTERN LISTINGFILE EXTENSIONSTOAVOID)
+                                                             (* ; "Edited  3-Nov-94 15:06 by jds")
+
+    (* ;; "Compare the contents of two directories, e.g., for change-control purposes.  Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other.  If SHOW=FILESTOO, then files that are the same are also listed.  LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.")
+
+    (LET ((LISTINGSTREAM (COND
+                            [LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'INTERPRESS '(LANDSCAPE T]
+                            (T NIL)))
+          FROM-GENERATOR TO-GENERATOR)
+         (COND
+            (LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN)
+                   [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT FROMDIR " vs " TODIR)
+                                                          (CONCAT "as of " (DATE]
+                   (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM)))
+         [SETQ FROM-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY FROMDIR 'BODY
+                                                     (OR FILEPATTERN '*.*;))
+                                     NIL
+                                     '(SORT]
+         [SETQ TO-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY TODIR 'BODY
+                                                   (OR FILEPATTERN '*.*;))
+                                   NIL
+                                   '(SORT]
+         [bind FROM-FILE TO-FILE first (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))
+                                           (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))
+            repeatwhile (OR FROM-FILE TO-FILE) bind DT1 DT2 TON SHORT-FROM SHORT-TO
+            do (COND
+                      ((AND FROM-FILE (CL:MEMBER (UNPACKFILENAME.STRING FROM-FILE 'EXTENSION)
+                                             EXTENSIONSTOAVOID :TEST #'STRING-EQUAL))
+
+                       (* ;; "FROM file is on the prohibited-extension list.  Skip it.")
+
+                       (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)))
+                      ((AND TO-FILE (CL:MEMBER (UNPACKFILENAME.STRING TO-FILE 'EXTENSION)
+                                           EXTENSIONSTOAVOID :TEST #'STRING-EQUAL))
+
+                       (* ;; "TO file is on the prohibited-extension list.  Skip it.")
+
+                       (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)))
+                      (T (SETQ SHORT-FROM (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL
+                                                 'BODY FROM-FILE))
+                         (SETQ SHORT-TO (PACKFILENAME.STRING 'HOST NIL 'DIRECTORY NIL 'VERSION NIL
+                                               'BODY TO-FILE))
+                         (HELP)
+                         (COND
+                            ((NOT FROM-FILE)
+
+                             (* ;; " Ran out of FROM files first; print the missing-FROM marker")
+
+                             (COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**"
+                                    (GETFILEINFO TO-FILE 'CREATIONDATE)
+                                    SHORT-TO
+                                    (GETFILEINFO TO-FILE 'AUTHOR))
+                             (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)))
+                            ((NOT TO-FILE)
+
+                             (* ;; " Ran out of TO files first; print the missing-TO marker")
+
+                             (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO
+                                                                                   FROM-FILE
+                                                                                   'AUTHOR)
+                                    (GETFILEINFO FROM-FILE 'CREATIONDATE)
+                                    "**" "" "" "")
+                             (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)))
+                            ((CL:STRING-LESSP SHORT-FROM SHORT-TO)
+
+                             (* ;; 
+                           "This FROM file has no TO equivalent.  Print the missing-FROM marker")
+
+                             (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM (GETFILEINFO
+                                                                                   FROM-FILE
+                                                                                   'AUTHOR)
+                                    (GETFILEINFO FROM-FILE 'CREATIONDATE)
+                                    "**" "" "" "")
+                             (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)))
+                            ((CL:STRING-LESSP SHORT-TO SHORT-FROM)
+
+                             (* ;; 
+                           "This TO file has no FROM equivalent.  Print the missing-TO marker")
+
+                             (COMPAREDIRS.FORMATLINE LISTINGSTREAM "" "" "" "**"
+                                    (GETFILEINFO TO-FILE 'CREATIONDATE)
+                                    SHORT-TO
+                                    (GETFILEINFO TO-FILE 'AUTHOR))
+                             (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR)))
+                            ([= (SETQ DT1 (GETFILEINFO FROM-FILE 'ICREATIONDATE))
+                                (SETQ DT2 (GETFILEINFO TO-FILE 'ICREATIONDATE]
+                             (AND SHOW=FILESTOO (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM
+                                                       "" (GDATE DT1)
+                                                       "=="
+                                                       (GDATE DT2)
+                                                       SHORT-TO ""))
+                             (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))
+                             (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)))
+                            (T (COMPAREDIRS.FORMATLINE LISTINGSTREAM SHORT-FROM
+                                      (GETFILEINFO FROM-FILE 'AUTHOR)
+                                      (GDATE DT1)
+                                      (COND
+                                         ((LESSP DT1 DT2)
+                                          "<<")
+                                         (T ">>"))
+                                      (GDATE DT2)
+                                      SHORT-TO
+                                      (GETFILEINFO TO-FILE 'AUTHOR))
+                               (SETQ TO-FILE (\GENERATENEXTFILE TO-GENERATOR))
+                               (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR]
+         (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM])
+)
+
+
+
+(* ;; "look for compiled files older than the sources")
+
+(DEFINEQ
+
+(FIND-UNCOMPILED-FILES
+  [LAMBDA (FROMDIR TODIR LISTINGFILE)                    (* ; "Edited  3-Nov-94 15:17 by jds")
+
+    (* ;; "Compare the contents of two directories, e.g., for change-control purposes.  Compares files matching FILEPATTERN (or *.*;) on FROMDIR and TODIR, listing which is newer, or when one is not found on the other.  If SHOW=FILESTOO, then files that are the same are also listed.  LISTINGFILE is either a filename for an interpress master, or NIL to go to the display.")
+
+    (LET ((LISTINGSTREAM (COND
+                            [LISTINGFILE (OPENIMAGESTREAM LISTINGFILE 'POSTSCRIPT '(LANDSCAPE T]
+                            (T NIL)))
+          FROM-GENERATOR TO-GENERATOR)
+         (COND
+            (LISTINGSTREAM (STREAMPROP LISTINGSTREAM 'AFTERNEWPAGEFN #'COMPAREDIRECTORIES.NEWPAGEFN)
+                   [STREAMPROP LISTINGSTREAM 'TITLE (CONS (CONCAT "Compiled-file search of " FROMDIR
+                                                                 " vs " TODIR)
+                                                          (CONCAT "as of " (DATE]
+                   (COMPAREDIRECTORIES.NEWPAGEFN LISTINGSTREAM)))
+         [SETQ FROM-GENERATOR (\GENERATEFILES (PACKFILENAME.STRING 'BODY FROMDIR 'BODY "*.;")
+                                     NIL
+                                     '(SORT]
+         (bind FROM-FILE first (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR))
+            repeatwhile FROM-FILE bind DT1 DT2 TON SHORT-FROM SHORT-TO
+            do (COND
+                      [[SETQ TO-FILE (OR (INFILEP (PACKFILENAME 'DIRECTORY TODIR 'VERSION NIL
+                                                         'EXTENSION
+                                                         'DFASL
+                                                         'BODY FROM-FILE))
+                                         (INFILEP (PACKFILENAME 'DIRECTORY TODIR 'VERSION NIL
+                                                         'EXTENSION
+                                                         'LCOM
+                                                         'BODY FROM-FILE]
+                       (COND
+                          ((< (GETFILEINFO TO-FILE 'ICREATIONDATE)
+                              (GETFILEINFO FROM-FILE 'ICREATIONDATE))
+                           (PRINTOUT LISTINGSTREAM FROM-FILE " (" (GETFILEINFO FROM-FILE 
+                                                                         'CREATIONDATE)
+                                  ") vs " TO-FILE " (" (GETFILEINFO TO-FILE 'CREATIONDATE)
+                                  ")" T]
+                      (T (PRINTOUT LISTINGSTREAM FROM-FILE " has no compiled equivalent." T)))
+                  (SETQ FROM-FILE (\GENERATENEXTFILE FROM-GENERATOR)))
+         (AND LISTINGSTREAM (CLOSEF LISTINGSTREAM])
+)
+(PUTPROPS COMPAREDIRECTORIES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1994))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1101 18001 (COMPAREDIRECTORIES 1111 . 6716) (COMPAREDIRS.FORMATLINE 6718 . 9842) (
+COMPAREDIRECTORIES.NEWPAGEFN 9844 . 11111) (COMPARE-DIRECTORIES 11113 . 17999)) (18066 20910 (
+FIND-UNCOMPILED-FILES 18076 . 20908)))))
+STOP
diff --git a/internal/library/COMPARESOURCES b/internal/library/COMPARESOURCES
new file mode 100644
index 00000000..e8c99df1
--- /dev/null
+++ b/internal/library/COMPARESOURCES
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "22-May-92 15:59:20" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>COMPARESOURCES.;4| 16160  

      changes to%:  (FNS COMPARESOURCES)

      previous date%: "15-Jun-90 12:42:19" 
|{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>COMPARESOURCES.;3|)


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

(PRETTYCOMPRINT COMPARESOURCESCOMS)

(RPAQQ COMPARESOURCESCOMS
       ((FNS COMPARESOURCES \CS.COMPARE.MASTERS \CS.COMPARE.TYPES \CS.SORT.DECLARES \CS.SORT.DECLARE1
             \CS.FILTER.GARBAGE)
        (FNS \CS.ISVARFORM \CS.COMPARE.VARS \CS.ISMACROFORM \CS.ISRECFORM \CS.ISCOURIERFORM 
             \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES \CS.ISPROPFORM \CS.PROP.NAME \CS.COMPARE.PROPS
             \CS.ISADDVARFORM \CS.COMPARE.ADDVARS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS)
        (VARS COMPARESOURCETYPES DEFAULT.DECLARE.TAGS)
        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CSTYPE)
               (GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS))))
(DEFINEQ

(COMPARESOURCES
  [LAMBDA (FILEX FILEY EXAMINE DW? LISTSTREAM)           (* ; "Edited 22-May-92 15:58 by jds")

    (* ;; "Compare two lisp source files (FILEX and FILEY), reporting differences. ")

    (* ;; "If DW? dwimify expressions before comparing.")

    (* ;; 
  "If EXAMINE, open an editor on differences.  EXAMINE can also be one or a list of these values:")

    (* ;; "   NEW -- edit any new function that doesn't appear on old file")

    (* ;; "   OLD -- edit any changes")

    (* ;; "   MISC -- filecoms changes get edited")

    (* ;; "   T -- EVERY change is edited.")

    (* ;; "LISTSTREAM is the stream to list changes to.")

    (DECLARE (SPECVARS FILEX FILEY EXAMINE DIFFERENCES))
    (PROG (DIFFERENCES BODYX BODYY ENVX ENVY DECLAREX DECLAREY)
          [SETQ FILEX (OR (FINDFILE FILEX T)
                          (RETURN (printout LISTSTREAM FILEX " not found" T]
          [SETQ FILEY (OR (FINDFILE FILEY T)
                          (RETURN (printout LISTSTREAM FILEY " not found" T]

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

          (CL:MULTIPLE-VALUE-SETQ (BODYX ENVX)
                 (READFILE FILEX))
          (SETQ BODYX (\CS.FILTER.GARBAGE BODYX))
          (CL:MULTIPLE-VALUE-SETQ (BODYY ENVY)
                 (READFILE FILEY))
          (SETQ BODYY (\CS.FILTER.GARBAGE BODYY))
          (printout LISTSTREAM "Comparing " FILEX " dated " (GETFILEINFO FILEX 'CREATIONDATE)
                 " and " FILEY " dated " (GETFILEINFO FILEY 'CREATIONDATE)
                 ":" T T)
          [SETQ DECLAREX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR)
                                                                                  'DECLARE%:]
          (SETQ BODYX (CL:SET-DIFFERENCE BODYX DECLAREX))
          [SETQ DECLAREY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR)
                                                                                  'DECLARE%:]
          (SETQ BODYY (CL:SET-DIFFERENCE BODYY DECLAREY))
          (WITH-READER-ENVIRONMENT (OR ENVX ENVY (MAKE-READER-ENVIRONMENT))
              (\CS.COMPARE.MASTERS BODYX BODYY DW? LISTSTREAM)

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

              (SETQ BODYX (\CS.SORT.DECLARES DECLAREX))
              (SETQ BODYY (\CS.SORT.DECLARES DECLAREY))
              [SETQ BODYX (APPEND BODYX (for Y in BODYY collect (LIST (CAR Y))
                                           unless (SASSOC (CAR Y)
                                                             BODYX]
                                                             (* ; 
                "Add placeholders for any declaration types in Y not in X to simplify what follows")
              [for X in BODYX bind Y TYPE
                 do (SETQ Y (SASSOC (CAR X)
                                       BODYY))
                       (SETQ TYPE (CAR X))
                       [SETQ X (LDIFFERENCE (CDR X)
                                      (PROG1 (CDR Y)
                                          (SETQ Y (LDIFFERENCE (CDR Y)
                                                         X)))]
                       (COND
                          ((OR X Y)
                           (printout LISTSTREAM T "------" [CONS 'DECLARE%: (APPEND (
                                                                                    CL:SET-DIFFERENCE
                                                                                     TYPE 
                                                                                 DEFAULT.DECLARE.TAGS
                                                                                     )
                                                                                   '(--]
                                  " forms------" T)          (* ; 
                         "REVERSE because \CS.SORT.DECLARES delivered expressions in reverse order")
                           (\CS.COMPARE.MASTERS (REVERSE X)
                                  (REVERSE Y)
                                  DW? LISTSTREAM]
              (TERPRI LISTSTREAM))
          (RETURN (REVERSE DIFFERENCES])

(\CS.COMPARE.MASTERS
(LAMBDA (BODYX BODYY DW? LISTSTREAM) (* ; "Edited 15-Apr-88 14:41 by bvm") (LET (FNSX FNSY YTHING XTHING PRED DIFS Y TMP DEFFERS) (DECLARE (USEDFREE DIFFERENCES)) (SETQ FNSX (for EXPR in BODYX collect EXPR when (EQ (CAR EXPR) (QUOTE DEFINEQ)))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX FNSX)) (SETQ FNSX (for BOD in FNSX join (CDR BOD))) (SETQ FNSY (for EXPR in BODYY collect EXPR when (EQ (CAR EXPR) (QUOTE DEFINEQ)))) (SETQ BODYY (CL:SET-DIFFERENCE BODYY FNSY)) (SETQ FNSY (for BOD in FNSY join (CDR BOD))) (COND ((OR FNSX FNSY) (printout LISTSTREAM "---Functions: " T) (COND (DW? (LET ((NOSPELLFLG T)) (DECLARE (SPECVARS NOSPELLFLG)) (for X in FNSX when (SETQ Y (ASSOC (CAR X) FNSY)) do (* ; "Only bother dwimifying the ones that look different") (DWIMIFY (CADR X) T) (DWIMIFY (CADR Y) T))))) (COND ((SETQ DIFS (\CS.COMPARE.TYPES FNSX FNSY NIL (FUNCTION (LAMBDA (X Y STREAM) (COMPARELISTS (CADR X) (CADR Y) STREAM))) (FUNCTION CAR) LISTSTREAM)) (push DIFFERENCES (CONS (QUOTE FNS) DIFS)))))) (for TYPE in FILEPKGTYPES when (AND (CL:SYMBOLP TYPE) (SETQ DEFFERS (GET TYPE :DEFINED-BY))) do (* ;; "handle definer based things") (for DEFFER in DEFFERS do (SETQ XTHING (for X in BODYX collect X when (EQ (CAR X) DEFFER))) (SETQ YTHING (for X in BODYY collect X when (EQ (CAR X) DEFFER))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING)) (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING)) (COND ((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (CONCAT (OR (CL:DOCUMENTATION TYPE (QUOTE DEFINE-TYPES)) TYPE) " defined by " DEFFER) NIL (GET DEFFER :DEFINITION-NAME) LISTSTREAM)) (COND ((SETQ TMP (ASSOC TYPE DIFFERENCES)) (NCONC TMP DIFS)) (T (push DIFFERENCES (CONS TYPE DIFS)))))))) (for TYPE in COMPARESOURCETYPES do (SETQ PRED (fetch (CSTYPE PREDFN) of TYPE)) (SETQ XTHING (for X in BODYX collect X when (CL:FUNCALL PRED X))) (SETQ YTHING (for X in BODYY collect X when (CL:FUNCALL PRED X))) (SETQ BODYX (CL:SET-DIFFERENCE BODYX XTHING)) (SETQ BODYY (CL:SET-DIFFERENCE BODYY YTHING)) (COND ((SETQ DIFS (\CS.COMPARE.TYPES XTHING YTHING (OR (fetch (CSTYPE TITLE) of TYPE) (L-CASE (MKSTRING (fetch (CSTYPE FPKGTYPE) of TYPE)) T)) (fetch (CSTYPE COMPAREFN) of TYPE) (OR (fetch (CSTYPE IDFN) of TYPE) (FUNCTION CADR)) LISTSTREAM)) (SETQ TYPE (fetch (CSTYPE FPKGTYPE) of TYPE)) (COND ((SETQ TMP (ASSOC TYPE DIFFERENCES)) (NCONC TMP DIFS)) (T (push DIFFERENCES (CONS TYPE DIFS))))))) (SETQ BODYY (LDIFFERENCE BODYY (PROG1 BODYX (SETQ BODYX (LDIFFERENCE BODYX BODYY))))) (COND ((OR BODYX BODYY) (printout LISTSTREAM T "---Expressions:" T) (LET ((COMMENTX 0) (COMMENTY 0) EXTRAS) (* ; "Remove comments") (SETQ BODYX (for X in BODYX collect X unless (COND ((EQ (CAR X) COMMENTFLG) (add COMMENTX 1) T)))) (SETQ BODYY (for Y in BODYY collect Y unless (COND ((EQ (CAR Y) COMMENTFLG) (add COMMENTY 1) T)))) (COND ((OR (NEQ COMMENTX 0) (NEQ COMMENTY 0)) (printout LISTSTREAM |.I1| COMMENTX " comments -> " |.I1| COMMENTY " comments." T T))) (COND ((SETQ EXTRAS (COND (BODYX (COND (BODYY (COMPARELISTS BODYX BODYY LISTSTREAM) NIL) (T (printout LISTSTREAM "These are not on " FILEY) BODYX))) (BODYY (printout LISTSTREAM "These are not on " FILEX) BODYY))) (printout LISTSTREAM ":" T) (for X in EXTRAS do (LVLPRINT X LISTSTREAM 2 3)))) (COND ((AND (OR BODYX BODYY) (OR (EQ EXAMINE T) (EQMEMB (QUOTE MISC) EXAMINE))) (EDITE (LIST BODYX BODYY)))) (OR (ASSOC (QUOTE Other) DIFFERENCES) (push DIFFERENCES (LIST (QUOTE Other) (QUOTE --)))))))))
)

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

(\CS.SORT.DECLARES
(LAMBDA (DECLS) (* bvm%: "15-Nov-85 18:58") (* ;;; "Sorts DECLS, a list of (DECLARE: --) expressions, into a set of declarations by tag, returning a list of entries of the form (tags  . expressions)") (LET (RESULT) (DECLARE (SPECVARS RESULT)) (for DEC in DECLS do (\CS.SORT.DECLARE1 DEC DEFAULT.DECLARE.TAGS)) RESULT))
)

(\CS.SORT.DECLARE1
(LAMBDA (DEC TAGLST) (* bvm%: "15-Nov-85 19:09") (DECLARE (USEDFREE RESULT)) (* ;;; "Process one DECLARE: expression, partitioning it into subdeclarations put on RESULT assuming that the default tags in effect by the time you get here are in TAGLST") (for TAIL on (CDR DEC) bind CURRENT TAG COMPLEMENT do (COND ((NLISTP (SETQ TAG (CAR TAIL))) (* ; "Canonicalize tag") (SELECTQ TAG (DOEVAL@LOAD (SETQQ TAG EVAL@LOAD)) (DOEVAL@COMPILE (SETQQ TAG EVAL@COMPILE)) (DOCOPY (SETQQ TAG COPY)) NIL) (COND ((NOT (MEMB TAG TAGLST)) (SETQ TAGLST (COND ((STRPOS (QUOTE WHEN) TAG) (* ; "These take an extra expression") (APPEND TAGLST (LIST TAG (CAR (SETQ TAIL (CDR TAIL)))))) ((FMEMB (SETQ COMPLEMENT (SELECTQ TAG (COPY (QUOTE DONTCOPY)) (DONTCOPY (QUOTE COPY)) (EVAL@COMPILE (QUOTE DONTEVAL@COMPILE)) (DONTEVAL@COMPILE (QUOTE EVAL@COMPILE)) (EVAL@LOAD (QUOTE DONTEVAL@LOAD)) (DONTEVAL@LOAD (QUOTE EVAL@LOAD)) (FIRST (QUOTE NOTFIRST)) (NOTFIRST (QUOTE FIRST)) NIL)) TAGLST) (SUBST TAG COMPLEMENT TAGLST)) (T (APPEND TAGLST (LIST TAG))))) (SETQ CURRENT NIL)))) ((EQ (CAR TAG) (QUOTE DECLARE%:)) (* ; "Process embedded declaration") (\CS.SORT.DECLARE1 TAG TAGLST)) (T (* ; "Stick this expression on the entry for the tags that tell when to eval it") (COND ((AND (NOT CURRENT) (NOT (SETQ CURRENT (SASSOC TAGLST RESULT)))) (SETQ RESULT (NCONC1 RESULT (SETQ CURRENT (LIST TAGLST)))))) (push (CDR CURRENT) TAG)))))
)

(\CS.FILTER.GARBAGE
(LAMBDA (FILECONTENTS) (* ; "Edited 29-Dec-86 10:44 by jds") (* ;;; "Remove %"Uninteresting%" items from files to be compared.  Removes FILECREATED form, filemap, copyright notice, and DECLARE: DONTCOPY items.") (for X in FILECONTENTS collect X unless (OR (EQ (CAR X) (QUOTE FILECREATED)) (AND (EQ (CAR X) (QUOTE DECLARE%:)) (EQ (CADR X) (QUOTE DONTCOPY)) (LISTP (CADDR X)) (OR (FMEMB (QUOTE COPYRIGHT) (CADDR X)) (FMEMB (QUOTE FILEMAP) (CADDR X)))))))
)
)
(DEFINEQ

(\CS.ISVARFORM
(LAMBDA (X) (* bvm%: "25-Sep-85 12:05") (SELECTQ (CAR X) ((RPAQ RPAQQ RPAQ?) T) NIL)))

(\CS.COMPARE.VARS
(LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Compares two variable setting forms") (COND ((EQ (CAR X) (CAR Y)) (* ; "Same type of setting fn") (COMPARELISTS (CADDR X) (CADDR Y) STREAM)) (T (LET ((XVAL (COND ((EQ (CAR X) (QUOTE RPAQQ)) (KWOTE (CADDR X))) (T (CADDR X)))) (YVAL (COND ((EQ (CAR Y) (QUOTE RPAQQ)) (KWOTE (CADDR Y))) (T (CADDR Y))))) (COND ((EQUAL XVAL YVAL) (* ; "Same value, different setter") (printout STREAM (COND ((EQ (CAR X) (QUOTE RPAQ?)) (QUOTE INITVARS)) (T (QUOTE VARS))) " -> " (COND ((EQ (CAR Y) (QUOTE RPAQ?)) (QUOTE INITVARS)) (T (QUOTE VARS))) T)) (T (COMPARELISTS XVAL YVAL STREAM)))))))
)

(\CS.ISMACROFORM
(LAMBDA (X) (* bvm%: "25-Sep-85 12:19") (SELECTQ (CAR X) (DEFMACRO T) (PUTPROPS (FMEMB (CADDR X) MACROPROPS)) NIL))
)

(\CS.ISRECFORM
(LAMBDA (X) (* bvm%: "25-Sep-85 12:20") (FMEMB (CAR X) CLISPRECORDTYPES)))

(\CS.ISCOURIERFORM
(LAMBDA (X) (* bvm%: "13-Mar-86 16:21") (EQ (CAR X) (QUOTE COURIERPROGRAM))))

(\CS.ISTEMPLATEFORM
(LAMBDA (X) (* bvm%: "13-Mar-86 16:20") (EQ (CAR X) (QUOTE SETTEMPLATE))))

(\CS.COMPARE.TEMPLATES
(LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Templates usually look like (SETTEMPLATE (QUOTE FN) (QUOTE TEMPLATE))") (COND ((AND (EQUAL (CADR X) (CADR Y)) (EQ (CAR (CADDR X)) (QUOTE QUOTE)) (EQ (CAR (CADDR Y)) (QUOTE QUOTE))) (COMPARELISTS (CADR (CADDR X)) (CADR (CADDR Y)) STREAM)) (T (COMPARELISTS X Y STREAM))))
)

(\CS.ISPROPFORM
(LAMBDA (X) (* bvm%: "13-Mar-86 16:34") (* ;;; "(PUTPROPS SYMBOL PROP VALUE)") (AND (EQ (CAR X) (QUOTE PUTPROPS)) (NULL (CDDDDR X))))
)

(\CS.PROP.NAME
(LAMBDA (X) (* bvm%: "13-Mar-86 16:29") (* ;;; "The 'Name' of a property is its atom/value pair") (LIST (CADR X) (CADDR X)))
)

(\CS.COMPARE.PROPS
(LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "Compare the values") (COMPARELISTS (CADDDR X) (CADDDR Y) STREAM))
)

(\CS.ISADDVARFORM
(LAMBDA (X) (* bvm%: "13-Mar-86 16:40") (EQ (CAR X) (QUOTE ADDTOVAR))))

(\CS.COMPARE.ADDVARS
(LAMBDA (X Y STREAM) (* ; "Edited 29-Dec-86 12:15 by jds") (* ;;; "(ADDTOVAR ListName . values)") (COMPARELISTS (CDDR X) (CDDR Y) STREAM))
)

(\CS.ISFPKGCOMFORM
(LAMBDA (X) (* bvm%: "13-Mar-86 16:50") (* * (PUTDEF (QUOTE name) (QUOTE FILEPKGCOMS) (QUOTE stuff))) (AND (EQ (CAR X) (QUOTE PUTDEF)) (EQUAL (CADDR X) (QUOTE (QUOTE FILEPKGCOMS)))))
)

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

(RPAQQ COMPARESOURCETYPES
       ((VARS \CS.ISVARFORM \CS.COMPARE.VARS)
        (MACROS \CS.ISMACROFORM)
        (RECORDS \CS.ISRECFORM)
        (PROPS \CS.ISPROPFORM \CS.COMPARE.PROPS \CS.PROP.NAME "Properties")
        (ADDVARS \CS.ISADDVARFORM \CS.COMPARE.ADDVARS CADR "Additions to lists")
        (TEMPLATES \CS.ISTEMPLATEFORM \CS.COMPARE.TEMPLATES CADADR)
        (COURIERPROGRAMS \CS.ISCOURIERFORM)
        (FILEPKGCOMS \CS.ISFPKGCOMFORM \CS.COMPARE.FPKGCOMS CADADR)))

(RPAQQ DEFAULT.DECLARE.TAGS (EVAL@LOAD DONTEVAL@COMPILE COPY NOTFIRST))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD CSTYPE (FPKGTYPE PREDFN COMPAREFN IDFN TITLE))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS COMPARESOURCETYPES CLISPRECORDTYPES MACROPROPS DEFAULT.DECLARE.TAGS)
)
)
(PUTPROPS COMPARESOURCES COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1992))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1144 12512 (COMPARESOURCES 1154 . 5579) (\CS.COMPARE.MASTERS 5581 . 9012) (
\CS.COMPARE.TYPES 9014 . 10263) (\CS.SORT.DECLARES 10265 . 10608) (\CS.SORT.DECLARE1 10610 . 12030) (
\CS.FILTER.GARBAGE 12032 . 12510)) (12513 15241 (\CS.ISVARFORM 12523 . 12628) (\CS.COMPARE.VARS 12630
 . 13292) (\CS.ISMACROFORM 13294 . 13432) (\CS.ISRECFORM 13434 . 13527) (\CS.ISCOURIERFORM 13529 . 
13629) (\CS.ISTEMPLATEFORM 13631 . 13729) (\CS.COMPARE.TEMPLATES 13731 . 14096) (\CS.ISPROPFORM 14098
 . 14253) (\CS.PROP.NAME 14255 . 14400) (\CS.COMPARE.PROPS 14402 . 14559) (\CS.ISADDVARFORM 14561 . 
14654) (\CS.COMPARE.ADDVARS 14656 . 14821) (\CS.ISFPKGCOMFORM 14823 . 15030) (\CS.COMPARE.FPKGCOMS 
15032 . 15239)))))
STOP
\ No newline at end of file
diff --git a/internal/library/COMPARESOURCES.TEDIT b/internal/library/COMPARESOURCES.TEDIT
new file mode 100644
index 00000000..8ae99927
Binary files /dev/null and b/internal/library/COMPARESOURCES.TEDIT differ
diff --git a/internal/library/COMPTEST b/internal/library/COMPTEST
new file mode 100644
index 00000000..a66b6413
--- /dev/null
+++ b/internal/library/COMPTEST
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "15-Jun-90 13:37:15" {DSK}<usr>local>lde>lispcore>internal>library>COMPTEST.;2 91945  

      changes to%:  (VARS COMPTESTCOMS)

      previous date%: "17-Jun-88 18:52:58" {DSK}<usr>local>lde>lispcore>internal>library>COMPTEST.;1
)


(* ; "
Copyright (c) 1984, 1985, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT COMPTESTCOMS)

(RPAQQ COMPTESTCOMS
       [(FNS MAKEFORM TESTER TEST1 TRY FAILTEST TESTVALS TESTIFSAME TESTPAIRS EVALVARS TRYTEST)
        (ADDVARS (TESTS TESTVAR TESTTYPE TESTRET TESTOP TESTNUM TESTMORE TESTMISC TESTMAP TESTLINK 
                        TESTJUMP TESTFNX TESTFN TESTEDIT TESTCONS TESTCAR TESTCALL TESTC2 TESTC 
                        TESTBIND TESTAT TEST3))
        (COMS (FNS IVAR PVAR VARSWAP VARSWAP2 VARSWAP3 VARSWAP4 IVAR3 IVARX FVAR)
              (VARS TESTVAR)
              (FNS .GETPROPLST)
              (FNS .LISTP .NLISTP .LITATOM .FLOATP .FIXP .NUMBERP .SMALLP .STACKP .ARRAYP .NLITATOM 
                   .NFLOATP .NNUMBERP .NFIXP .NSMALLP .NARRAYP .NSTACKP .NZEROP .ZEROP .STRINGP 
                   .NSTRINGP .IGREATERP .NIGREATERP .ILESSP .NILESSP .ATOM .NATOM .EQ .NEQ .NULL 
                   .NNULL .IEQP .NIEQP .ORLISTP .ANDLISTP .ORATOM .ANDATOM .ORZEROP .ORNULL .ORARRAYP
                   .ANDARRAYP .ANDNLISTP .ANDNATOM .ORFLOATP .ANDFLOATP)
              (VARS TESTTYPE)
              (FNS .CONDRET .CONDRET2 TESTRESUME GETLEAVES)
              (VARS TESTRET)
              (FNS .TESTARG .SET .EVALV1 .EVALV2 .SUM .FIX .LIST .NLSETQ .EQUAL .SETX)
              (VARS TESTOP)
              (FNS .ITIMES .IPLUS .IQUOTIENT .IREMAINDER .ADD1 .SUB1 .LLSH .LRSH .LSH .RSH .LOGAND 
                   .LOGOR .LOGXOR .IDIFFERENCE .NT1 .NT2 .NT3)
              (VARS TESTNUM)
              (FNS .NCONC ..NCONC .AND .FRPLNODE .OR .FRPLNODE2 ..NCONC3 .NCONC3 SELECTTEST .MKLIST 
                   .EQMEMB .NCONC1 .GETPROPLIST .SETPROPLIST .FGETD ..FRPLNODE2 !AND !OR)
              (VARS TESTMORE)
              (FNS !ADD1VAR !APPEND APPEND2 !ASSOC !ATTACH !CHANGEPROP !COPY !DEFLIST !DREMOVE 
                   !DREVERSE DREV !DSUBST !EVERY !GETP !INTERSECTION !LAST !LASTN !LDIFF !LENGTH 
                   !LISTGET !LSUBST !MAP !GET !GETLIS !MEMB !NTH .COLLCT .ENDCOLLCT MYAPPEND1 
                   MYAPPEND2 COLLCT ENDCOLLCT .ATTACH .APPEND0 .APPEND1 .APPEND2 .APPEND3 .APPEND4 
                   .MAPCGETP)
              (VARS TESTMISC)
              (FNS .MAP .MAPC .MAPCEFF)
              (VARS TESTMAP)
              (FNS .FPLUS .FTIMES .FDIFFERENCE .FQUOTIENT)
              (VARS TESTLINK)
              (FNS NONLOCALGO CNTDWN JUMPAROUND)
              (VARS TESTJUMP)
              (FNS FN2 FN3 FN1 .IVAR)
              (VARS TESTFNX)
              (FNS .GETP .GETPROP .RPLACA .RPLACD .FRPLACA .GET .FRPLACD .ASSOC .LENGTH .LAST 
                   .GETHASH .FMEMB)
              (VARS TESTFN)
              (VARS TESTEDIT)
              (FNS .CONS LIST0 LIST1 LIST2 LIST3 LIST4 LIST5 LIST6 LIST7 LIST8 LIST9 LIST10 LIST11 
                   LIST12 LIST13)
              (VARS TESTCONS)
              (FNS .CAR .CDR .CAAR .CDAR .CADR .CDDR .CAAAAR)
              (VARS TESTCAR)
              (FNS .LAM0 ..LAM0 .LAM1 ..LAM1 .NLAML LAM1LOC)
              (VARS TESTCALL)
              (FNS .PROGS .SPEC .COND .DELBIND)
              (VARS TESTC2)
              (FNS T1 T0 TT TNIL T-1 T2 T12 T377 T400Q T-400 TSTR .NILARGS)
              (VARS TESTC)
              (FNS .BIND0 .BIND1 .BIND2 .BIND3 .BIND4 .BINDASSOC .BIND5 .BINDPOP)
              (VARS TESTBIND)
              (VARS TESTAT)
              (FNS LAM0 LAM1 LAMA NLAML NLAMA)
              (FNS .SELECTQ .SUBFNS .MISC .FORTEST .BIGCOND .RECORDTEST .PROGRETURN .ALWAYSFALSE 
                   .ALWAYSTRUE .EQ1 .EQ2 .EQ3)
              (VARS TEST3))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
               (ADDVARS (NLAMA NLAMA TESTIFSAME TESTVALS)
                      (NLAML NLAML !ADD1VAR .NLSETQ TESTPAIRS)
                      (LAMA LAMA !APPEND .LIST .SUM .TESTARG])
(DEFINEQ

(MAKEFORM
  [LAMBDA (FORM)                                         (* ; "Edited  8-Apr-88 12:52 by amd")
    (SUBST FORM 'FORM '(LIST 1 FORM (COND
                                       (FORM 2)
                                       ((NOT FORM)
                                        3)
                                       (T 4))
                             (OR FORM 5)
                             (AND FORM 6)
                             (PROGN FORM 7])

(TESTER
  [LAMBDA (TESTLST)                                      (* ; "Edited  8-Apr-88 16:20 by amd")
    (HANDLER-BIND [(CL:ERROR #'(LAMBDA (C)
                                 (LET [(RESTART (CONDITIONS:FIND-RESTART 'COMPTEST-FAIL]
                                      (IF (NULL RESTART)
                                          THEN (HELP "Error signalled while not below TRY")
                                        ELSE (CONDITIONS:INVOKE-RESTART RESTART C]
           (TEST1 TESTLST])

(TEST1
  [LAMBDA (TESTLST)                                      (* ; "Edited  8-Apr-88 12:53 by amd")
    (COND
       ((NULL TESTLST)
        (MAPC TESTS 'TEST1))
       ((LITATOM TESTLST)
        (PRINT TESTLST T)
        (TEST1 (EVALV TESTLST)))
       (T (MAPC TESTLST 'EVAL])

(TRY
  [LAMBDA (FORM)                                         (* ; "Edited  8-Apr-88 16:19 by amd")
    (CONDITIONS:RESTART-CASE (EVAL FORM)
           (COMPTEST-FAIL (CONDITION)
                  (LIST :ERROR (CL:PRINC-TO-STRING CONDITION])

(FAILTEST
  [LAMBDA NIL
    (PRIN2 TEST T T)
    (PRIN1 " failed.
" T])

(TESTVALS
  [NLAMBDA L                                             (* ; "Edited 17-Jun-88 18:50 by amd")
    (PROG ((A 'A.TOP)
           (B 'B.TOP)
           (C 'C.TOP)
           (D 'D.TOP)
           (E 'E.TOP)
           (F 'F.TOP)
           (G 'G.TOP)
           (H 'H.TOP)
           (I 'I.TOP))
          (MAP L [FUNCTION (LAMBDA (X)
                             (OR (AND [CL:EQUALP [SETQ V1 (TRY (SETQ TEST (CAR X]
                                             (SETQ V2 (TRY (CADR X]
                                      (EQ (TYPENAME V1)
                                          (TYPENAME V2)))
                                 (FAILTEST]
               (FUNCTION CDDR])

(TESTIFSAME
  [NLAMBDA FNVALS                                        (* ; "Edited  8-Apr-88 12:53 by amd")
    (MAPC FNVALS (FUNCTION (LAMBDA (L V1 V2)
                             (OR (AND [EQUAL [SETQ V1 (TRY (SETQ TEST (CONS (CAR L)
                                                                            (CDDR L]
                                             (SETQ V2 (TRY (CDR L]
                                      (EQ (TYPENAME V1)
                                          (TYPENAME V2)))
                                 (FAILTEST])

(TESTPAIRS
  [NLAMBDA (FNL VALLST)                                  (* ; "Edited  8-Apr-88 12:53 by amd")
    (MAPC FNL (FUNCTION (LAMBDA (FNPR)
                          (MAP VALLST
                               (FUNCTION (LAMBDA (VLST)
                                           (MAPC
                                            VLST
                                            (FUNCTION (LAMBDA (VLST2)
                                                        (OR
                                                         (AND [EQUAL [SETQ V1
                                                                      (TRY (SETQ TEST
                                                                            (LIST (CAR FNPR)
                                                                                  (CAR VLST)
                                                                                  VLST2]
                                                                     (SETQ V2
                                                                      (TRY (CONS (CDR FNPR)
                                                                                 (CDR TEST]
                                                              (EQ (TYPENAME V1)
                                                                  (TYPENAME V2)))
                                                         (FAILTEST])

(EVALVARS
  [LAMBDA NIL                                            (* ; "Edited  8-Apr-88 12:54 by amd")
                                                             (* ; "lmm: 22-JUN-76 0 56")
    (MAPCAR '(A B C D E F G H) (FUNCTION EVALV])

(TRYTEST
  [LAMBDA (FORM1 FORM2)                                  (* ; "Edited  8-Apr-88 12:54 by amd")
                                                             (* ; "lmm: 24-JUN-76 4 41")
    (OR (EQUAL (TRY (SETQ TEST FORM1))
               (TRY FORM2))
        (FAILTEST])
)

(ADDTOVAR TESTS TESTVAR TESTTYPE TESTRET TESTOP TESTNUM TESTMORE TESTMISC TESTMAP TESTLINK 
                          TESTJUMP TESTFNX TESTFN TESTEDIT TESTCONS TESTCAR TESTCALL TESTC2 TESTC 
                          TESTBIND TESTAT TEST3)
(DEFINEQ

(IVAR
  [LAMBDA (A B C D E F G H I J K L M N O)
    (DECLARE (SPECVARS))
    (DECLARE (LOCALVARS . T))
    (LIST A B C D E F G H I J K L M N O])

(PVAR
  [LAMBDA (A B C D E F G H I J K L M N O)                (* ; "Edited  8-Apr-88 12:54 by amd")
                                                             (* ; "lmm: 19-JUN-76 0 14")
    (PROG (X Y Z)
          (DECLARE (LOCALVARS . T))
          (RETURN (LIST A B C D E F G H I J K L M N O])

(VARSWAP
  [LAMBDA (X Y Z W)                                      (* ; "Edited  8-Apr-88 12:54 by amd")
                                                             (* ; "lmm: 19-JUN-76 1 18")
    (DECLARE (LOCALVARS . T))
    (SETQ X Y)
    (SETQ Y Z)
    (SETQ Z W)
    (SETQ W 0)
    (LIST X Y Z W])

(VARSWAP2
  [LAMBDA (X Y Z W)                                      (* ; "Edited  8-Apr-88 12:55 by amd")
                                                             (* ; "lmm: 19-JUN-76 1 31")
    (PROG NIL
          (DECLARE (LOCALVARS . T))
          (SETQ X Y)
          (SETQ Y Z)
          (SETQ Z W)
          (SETQ W 0)
          (RETURN (LIST X Y Z W])

(VARSWAP3
  [LAMBDA NIL                                            (* ; "Edited  8-Apr-88 12:55 by amd")
                                                             (* ; "lmm: 19-JUN-76 1 34")
    (PROG NIL
          (SETQ X Y)
          (SETQ Y Z)
          (SETQ Z W)
          (SETQ W 0)
          (RETURN (LIST X Y Z W])

(VARSWAP4
  [LAMBDA NIL                                            (* ; "Edited  8-Apr-88 12:55 by amd")
                                                             (* ; "lmm: 19-JUN-76 1 45")
    (SETQ X Y)
    (SETQ Y Z)
    (SETQ Z W)
    (SETQ W 0)
    (LIST X Y Z W])

(IVAR3
  [LAMBDA (A B C D E F G H I J K L M N O)                (* ; "Edited  8-Apr-88 12:55 by amd")
                                                             (* ; "lmm: 19-JUN-76 3 24")
    (DECLARE (SPECVARS))
    (DECLARE (LOCALVARS . T))
    (PROG (Z W)
          (RETURN (PROG (X Y)
                        (RETURN (LIST A B C D E F G H I J K L M N O])

(IVARX
  [LAMBDA (A B C)                                        (* ; "Edited  8-Apr-88 12:55 by amd")
                                                             (* ; "lmm: 24-JUN-76 9 1")
    (DECLARE (LOCALVARS . T))
    (PROG ((D (CONS 1 A))
           (E (CONS 2 B))
           (F (CONS 3 C)))
          (RETURN (PROG ((H (CONS 4 D))
                         (I (CONS 5 E))
                         (J (CONS 6 F)))
                        (RETURN (LIST A B C D E F H I J])

(FVAR
  [LAMBDA NIL                                            (* ; "Edited  8-Apr-88 12:55 by amd")
                                                             (* ; "lmm: 24-JUN-76 13 28")
    (CONS F1 F2])
)

(RPAQQ TESTVAR
       [(TESTVALS (IVAR 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
               '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
               (PVAR 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
               '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
               (IVAR3 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
               '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
               (VARSWAP 1 2 3 4)
               '(2 3 4 0)
               (VARSWAP2 1 2 3 4)
               '(2 3 4 0)
               (PROG ((X 1)
                      (Y 2)
                      (Z 3)
                      (W 4))
                     (RETURN (VARSWAP3)))
               '(2 3 4 0)
               (PROG ((X 1)
                      (Y 2)
                      (Z 3)
                      (W 4))
                     (RETURN (VARSWAP4)))
               '(2 3 4 0)
               (IVARX -3 -2 -1)
               '(-3 -2 -1 (1 . -3)
                    (2 . -2)
                    (3 . -1)
                    (4 1 . -3)
                    (5 2 . -2)
                    (6 3 . -1])
(DEFINEQ

(.GETPROPLST
  [LAMBDA (X Y Z)
    (LIST 1 (GETPROPLIST X)
          (PROG1 3 (GETPROPLIST X])
)
(DEFINEQ

(.LISTP
  [LAMBDA (X)
    (LISTP X])

(.NLISTP
  [LAMBDA (X)
    (NLISTP X])

(.LITATOM
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 12:56 by amd")
                                                             (* ; "lmm: 18-JUN-76 14 59")
    (LITATOM X])

(.FLOATP
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 12:56 by amd")
                                                             (* ; "lmm: 18-JUN-76 14 59")
    (FLOATP X])

(.FIXP
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 12:56 by amd")
                                                             (* ; "lmm: 18-JUN-76 14 59")
    (FIXP X])

(.NUMBERP
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 12:56 by amd")
                                                             (* ; "lmm: 18-JUN-76 15 1")
    (NUMBERP X])

(.SMALLP
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 12:56 by amd")
                                                             (* ; "lmm: 18-JUN-76 15 7")
    (SMALLP X])

(.STACKP
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 12:57 by amd")
                                                             (* ; "lmm: 18-JUN-76 15 11")
    (STACKP X])

(.ARRAYP
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 12:57 by amd")
                                                             (* ; "lmm: 18-JUN-76 15 11")
    (ARRAYP X])

(.NLITATOM
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 12:57 by amd")
                                                             (* ; "lmm: 18-JUN-76 15 25")
    (NOT (LITATOM X])

(.NFLOATP
  [LAMBDA (X)
    (NOT (FLOATP X])

(.NNUMBERP
  [LAMBDA (X)
    (NOT (NUMBERP X])

(.NFIXP
  [LAMBDA (X)
    (NOT (FIXP X])

(.NSMALLP
  [LAMBDA (X)
    (NOT (SMALLP X])

(.NARRAYP
  [LAMBDA (X)
    (NOT (ARRAYP X])

(.NSTACKP
  [LAMBDA (X)
    (NOT (STACKP X])

(.NZEROP
  [LAMBDA (X)
    (NOT (ZEROP X])

(.ZEROP
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 12:58 by amd")
                                                             (* ; "lmm: 18-JUN-76 15 28")
    (ZEROP X])

(.STRINGP
  [LAMBDA (X)
    (STRINGP X])

(.NSTRINGP
  [LAMBDA (X)
    (NOT (STRINGP X])

(.IGREATERP
  [LAMBDA (X Y)
    (IGREATERP X Y])

(.NIGREATERP
  [LAMBDA (X Y)
    (NOT (IGREATERP X Y])

(.ILESSP
  [LAMBDA (X Y)
    (ILESSP X Y])

(.NILESSP
  [LAMBDA (X Y)
    (NOT (ILESSP X Y])

(.ATOM
  [LAMBDA (X)
    (ATOM X])

(.NATOM
  [LAMBDA (X)
    (NOT (ATOM X])

(.EQ
  [LAMBDA (X Y)
    (EQ X Y])

(.NEQ
  [LAMBDA (X Y)
    (NEQ X Y])

(.NULL
  [LAMBDA (X)
    (NULL X])

(.NNULL
  [LAMBDA (X)
    (COND
       ((NULL X)
        NIL)
       (T T])

(.IEQP
  [LAMBDA (X Y)
    (IEQP X Y])

(.NIEQP
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 12:59 by amd")
                                                             (* ; "lmm: 19-JUN-76 3 14")
    (NOT (IEQP X Y])

(.ORLISTP
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 12:59 by amd")
                                                             (* ; "lmm: 24-JUN-76 4 45")
    (OR (LISTP X)
        Y])

(.ANDLISTP
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 12:59 by amd")
                                                             (* ; "lmm: 24-JUN-76 4 45")
    (AND (LISTP X)
         Y])

(.ORATOM
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 13:00 by amd")
                                                             (* ; "lmm: 30-JUN-76 13 27")
    (OR (ATOM X)
        Y])

(.ANDATOM
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 13:00 by amd")
                                                             (* ; "lmm: 30-JUN-76 13 27")
    (AND (ATOM X)
         Y])

(.ORZEROP
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 13:00 by amd")
                                                             (* ; "lmm: 24-JUN-76 4 47")
    (OR (EQ X 0)
        Y])

(.ORNULL
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 13:00 by amd")
                                                             (* ; "lmm: 24-JUN-76 4 47")
    (OR (NULL X)
        Y])

(.ORARRAYP
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 13:00 by amd")
                                                             (* ; "lmm: 24-JUN-76 4 47")
    (OR (ARRAYP X)
        Y])

(.ANDARRAYP
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 13:00 by amd")
                                                             (* ; "lmm: 24-JUN-76 13 9")
    (AND (ARRAYP X)
         Y])

(.ANDNLISTP
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 13:00 by amd")
                                                             (* ; "lmm: 30-JUN-76 13 26")
    (AND (NOT (LISTP X))
         Y])

(.ANDNATOM
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 13:00 by amd")
                                                             (* ; "lmm: 30-JUN-76 13 28")
    (AND (NOT (ATOM X))
         Y])

(.ORFLOATP
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 13:01 by amd")
                                                             (* ; "lmm: 30-JUN-76 13 28")
    (OR (FLOATP X)
        Y])

(.ANDFLOATP
  [LAMBDA (Y X)                                          (* ; "Edited  8-Apr-88 13:01 by amd")
                                                             (* ; "lmm: 30-JUN-76 13 28")
    (AND (FLOATP X)
         Y])
)

(RPAQQ TESTTYPE
       [[MAPC '((.NLISTP .LISTP LISTP .ORLISTP .ANDLISTP)
                (.NATOM .ATOM ATOM .ORATOM .ANDATOM .ANDNATOM)
                (.NLITATOM .LITATOM LITATOM)
                (.NFLOATP .FLOATP FLOATP .ORFLOATP .ANDFLOATP)
                (.NNUMBERP .NUMBERP NUMBERP)
                (.NFIXP .FIXP FIXP)
                (.NSMALLP .SMALLP SMALLP)
                (.NARRAYP .ARRAYP ARRAYP .ORARRAYP .ANDARRAYP)
                (.NSTACKP .STACKP STACKP)
                (.NZEROP .ZEROP ZEROP .ORZEROP)
                (.NSTRINGP .STRINGP STRINGP)
                (.NNULL .NULL NULL .ORNULL))
              (FUNCTION (LAMBDA (L)
                               (MAPC [CONS (LIST)
                                           (CONS (LIST (ARRAY 2))
                                                 (CONS (LIST (STKNTH 0 T))
                                                       '((-1)
                                                         (0)
                                                         (1)
                                                         (1.0)
                                                         (100000)
                                                         ('A)
                                                         ('(A))
                                                         ("foo")
                                                         (NIL)
                                                         (T]
                                     (FUNCTION (LAMBDA (ARGL TX)
                                                      (TRYTEST (CONS (CADR L)
                                                                     ARGL)
                                                             (SETQ TX (CONS (CADDR L)
                                                                            ARGL)))
                                                      (TRYTEST (CONS (CAR L)
                                                                     ARGL)
                                                             (LIST 'NOT TX))
                                                      (AND (CADDDR L)
                                                           (TRYTEST (CONS (CADDDR L)
                                                                          (CONS 74 ARGL))
                                                                  (LIST 'OR TX 74)))
                                                      (AND (CAR (CDDDDR L))
                                                           (TRYTEST (CONS (CAR (CDDDDR L))
                                                                          (CONS 74 ARGL))
                                                                  (LIST 'AND TX 74)))
                                                      (AND (CADR (CDDDDR L))
                                                           (TRYTEST (CONS (CADR (CDDDDR L))
                                                                          (CONS 74 ARGL))
                                                                  (LIST 'AND (LIST 'NOT TX)
                                                                        74]
        (MAPC '((.NIGREATERP .IGREATERP IGREATERP)
                (.NILESSP .ILESSP ILESSP)
                (.NIEQP .IEQP IEQP)
                (.NEQ .EQ EQ))
              (FUNCTION (LAMBDA (L)
                               (MAPC '((1 -1)
                                       (-1 1)
                                       (100000 1)
                                       (100.0 1)
                                       (1 100.0)
                                       (100.0 200.0)
                                       (1 100000)
                                       (300000 -300000)
                                       (-300000 300000)
                                       (100000 100000))
                                     (FUNCTION (LAMBDA (ARGS)
                                                      (TRYTEST (CONS (CADR L)
                                                                     ARGS)
                                                             (CONS (CADDR L)
                                                                   ARGS))
                                                      (TRYTEST (CONS (CAR L)
                                                                     ARGS)
                                                             (LIST 'NOT (CONS (CADDR L)
                                                                              ARGS])
(DEFINEQ

(.CONDRET
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:01 by amd")
    (PROG NIL
          (COND
             (X (RETURN (CONS)))
             (T (RETURN 3])

(.CONDRET2
  [LAMBDA NIL                                            (* ; "Edited  8-Apr-88 13:01 by amd")
    (PROG (X)
          (COND
             ((RETURN X)
              T)
             (T 3])

(TESTRESUME
  [LAMBDA (STRUCTURE)
    (PROG (LEAF RESULT TESTPTR GETPTR)
          (COROUTINE TESTPTR GETPTR (GETLEAVES STRUCTURE GETPTR TESTPTR))
      LP  (COND
             ((SETQ LEAF (RESUME TESTPTR GETPTR))
              (SETQ RESULT (NCONC1 RESULT LEAF))
              (GO LP))
             (T (RETURN RESULT])

(GETLEAVES
  [LAMBDA (STRUC GETPTR TESTPTR)
    (COND
       ((LISTP STRUC)
        (GETLEAVES (CAR STRUC)
               GETPTR TESTPTR)
        (GETLEAVES (CDR STRUC)
               GETPTR TESTPTR))
       (STRUC (RESUME GETPTR TESTPTR STRUC])
)

(RPAQQ TESTRET
       [(TESTVALS (.CONDRET T)
               '(NIL)
               (.CONDRET)
               3
               (.CONDRET2 17)
               NIL
               [TESTRESUME '(1 (2 . 3)
                               (4 . 5) . 6]
               '(1 2 3 4 5 6])
(DEFINEQ

(.TESTARG
  [LAMBDA N                                              (* ; "Edited  8-Apr-88 13:01 by amd")
                                                             (* ; "lmm: 22-JUN-76 22 59")
    (LIST N (ARG N 1)
          (ARG N 2])

(.SET
  [LAMBDA (VAR VAL)                                      (* ; "Edited  8-Apr-88 13:02 by amd")
    (LIST 1 (SET VAR VAL)
          3])

(.EVALV1
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:02 by amd")
                                                             (* ; "lmm: 22-JUN-76 23 4")
    (EVALV X])

(.EVALV2
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:02 by amd")
                                                             (* ; "lmm: 22-JUN-76 23 5")
    (EVALV X Y])

(.SUM
  [LAMBDA N                                              (* ; "Edited  8-Apr-88 13:02 by amd")
                                                             (* ; "lmm: 24-JUN-76 14 59")
    (PROG ((I N)
           (V 0))
      LP  (COND
             ((ZEROP I)
              (RETURN V))
             (T (SETQ V (IPLUS V (ARG N I)))
                (SETQ I (SUB1 I))
                (GO LP])

(.FIX
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:02 by amd")
                                                             (* ; "lmm: 25-JUN-76 6 20")
    (FIX X])

(.LIST
  [LAMBDA L                                              (* ; "Edited  8-Apr-88 13:02 by amd")
                                                             (* ; "lmm: 30-JUN-76 14 50")
    (AND (NOT (ZEROP L))
         (PROG ((I L)
                V)
           LP  (COND
                  ((EQ I 1)
                   (RETURN (CONS (ARG L 1)
                                 V)))
                  (T (SETQ V (CONS (ARG L I)
                                   V))
                     (SETQ I (SUB1 I))
                     (GO LP])

(.NLSETQ
  [NLAMBDA (FORM)                                        (* ; "Edited  8-Apr-88 13:03 by amd")
                                                             (* ; "lmm: 1-JUL-76 10 44")
    (NLSETQ (EVAL FORM])

(.EQUAL
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:03 by amd")
    (LIST 1 (EQUAL X Y)
          3])

(.SETX
  [LAMBDA (X Y Z)
    (DECLARE (LOCALVARS . T))                        (* ; "Edited  8-Apr-88 13:03 by amd")
    (PROG (K L M)
          (COND
             (X (SETQ K -1))
             (T (SETQ K 3)))
          (COND
             (Y (SETQ L -4))
             (T (SETQ L 4)))
          (COND
             (Z (SETQ M -2))
             (T (SETQ M 2)))
          (RETURN (LIST K L M])
)

(RPAQQ TESTOP
       [(SETTOPVAL 'A 'A.TOPLEVEL)
        (TESTVALS (.TESTARG 10 4 12 'A 'B)
               '(5 10 4)
               (PROG (FOO)
                     (RETURN (LIST (.SET 'FOO 300)
                                   FOO)))
               '((1 300 3)
                 300)
               (.EVALV1 'A)
               'A.TOP
               (.EVALV2 'A)
               'A.TOP
               (.EVALV2 'A T)
               'A.TOPLEVEL
               (.SUM 34 -34)
               0
               (.SUM 10 9 8 -8 -9 -10)
               0
               (.FIX (SETQ TESTATOM 100000))
               TESTATOM
               (.FIX 1.3)
               1
               (.NLSETQ (ERROR!))
               NIL
               (.NLSETQ 'FOO)
               '(FOO)
               (.LIST)
               NIL
               (.LIST 1)
               '(1)
               (.LIST 1 2 3 4 5)
               '(1 2 3 4 5)
               (.EQUAL '((A)
                         "B" 4.0 "CDEFG")
                      '((A)
                        "B" 4 "CDEFG"))
               '(1 T 3)
               [.EQUAL '(("ABCDEFG" "IJ"))
                      '(("ABCDEGF" "IJ"]
               '(1 NIL 3)
               (.SETX T T T)
               '(-1 -4 -2)
               (.SETX)
               '(3 4 2])
(DEFINEQ

(.ITIMES
  [LAMBDA (X Y)
    (ITIMES X Y])

(.IPLUS
  [LAMBDA (X Y)
    (IPLUS X Y])

(.IQUOTIENT
  [LAMBDA (X Y)
    (IQUOTIENT X Y])

(.IREMAINDER
  [LAMBDA (X Y)
    (IREMAINDER X Y])

(.ADD1
  [LAMBDA (X)
    (ADD1 X])

(.SUB1
  [LAMBDA (X)
    (SUB1 X])

(.LLSH
  [LAMBDA (X Y)
    (LLSH X Y])

(.LRSH
  [LAMBDA (X Y)
    (LRSH X Y])

(.LSH
  [LAMBDA (X Y)
    (LSH X Y])

(.RSH
  [LAMBDA (X Y)
    (RSH X Y])

(.LOGAND
  [LAMBDA (X Y)
    (LOGAND X Y])

(.LOGOR
  [LAMBDA (X Y)
    (LOGOR X Y])

(.LOGXOR
  [LAMBDA (X Y)
    (LOGXOR X Y])

(.IDIFFERENCE
  [LAMBDA (X Y)
    (IDIFFERENCE X Y])

(.NT1
  [LAMBDA (X Y Z)
    (FTIMES (DIFFERENCE X Y)
           Z])

(.NT2
  [LAMBDA (X Y Z)
    (FTIMES (QUOTIENT X Y)
           Z])

(.NT3
  [LAMBDA (X Y Z)
    (FGREATERP (COND
                  (X Y)
                  (Z))
           0])
)

(RPAQQ TESTNUM
       ((TESTVALS (.NT1 1 2 3)
               -3.0
               (.NT2 1 2 3)
               0.0
               (.NT2 1.0 2 3)
               1.5
               (.NT3 T 3 4)
               T
               (.NT3 NIL 3 -4)
               NIL)
        (TESTPAIRS ((.LLSH . LLSH)
                    (.LRSH . LRSH)
                    (.LSH . LSH)
                    (.RSH . RSH))
               (0 3 -3 31 32 1 -1 0 -31 -32 NIL))
        (TESTPAIRS ((.ITIMES . ITIMES)
                    (.IPLUS . IPLUS)
                    (.IQUOTIENT . IQUOTIENT)
                    (.IREMAINDER . IREMAINDER)
                    (.ADD1 . ADD1)
                    (.SUB1 . SUB1)
                    (.LOGAND . LOGAND)
                    (.LOGOR . LOGOR)
                    (.LOGXOR . LOGXOR))
               (0 3 -3 2047 2048 -1 0 -1431655766 NIL))))
(DEFINEQ

(.NCONC
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:05 by amd")
                                                             (* ; "lmm: 19-JUN-76 20 21")
    (NCONC X Y])

(..NCONC
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:05 by amd")
                                                             (* ; "lmm: 19-JUN-76 20 46")
    (PROG NIL
          (NCONC X Y)
          (RETURN X])

(.AND
  [LAMBDA (X Y Z W)                                      (* ; "Edited  8-Apr-88 13:05 by amd")
                                                             (* ; "lmm: 19-JUN-76 20 54")
    (AND (EVAL X)
         (EVAL Y)
         (EVAL Z)
         (EVAL W])

(.FRPLNODE
  [LAMBDA (X A D)                                        (* ; "Edited  8-Apr-88 13:05 by amd")
                                                             (* ; "lmm: 19-JUN-76 21 23")
    (FRPLNODE X A D])

(.OR
  [LAMBDA (X Y Z W)                                      (* ; "Edited  8-Apr-88 13:05 by amd")
                                                             (* ; "lmm: 19-JUN-76 21 28")
    (OR (EVAL X)
        (EVAL Y)
        (EVAL Z)
        (EVAL W])

(.FRPLNODE2
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:06 by amd")
                                                             (* ; "lmm: 19-JUN-76 21 47")
    (FRPLNODE2 X Y])

(..NCONC3
  [LAMBDA (X Y Z)                                        (* ; "Edited  8-Apr-88 13:06 by amd")
                                                             (* ; "lmm: 19-JUN-76 23 9")
    (PROG NIL
          (NCONC X Y Z)
          (RETURN X])

(.NCONC3
  [LAMBDA (X Y Z W)                                      (* ; "Edited  8-Apr-88 13:06 by amd")
                                                             (* ; "lmm: 19-JUN-76 22 54")
    (NCONC X Y Z W])

(SELECTTEST
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:06 by amd")
                                                             (* ; "lmm: 19-JUN-76 22 16")
    (SELECTQ X
        (0 0)
        (1 1)
        (A 'A)
        ((B C D) 
             'C)
        NIL])

(.MKLIST
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:06 by amd")
                                                             (* ; "lmm: 21-JUN-76 0 56")
    (MKLIST X])

(.EQMEMB
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:06 by amd")
                                                             (* ; "lmm: 21-JUN-76 1 16")
    (EQMEMB X Y])

(.NCONC1
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:06 by amd")
                                                             (* ; "lmm: 21-JUN-76 1 33")
    (NCONC1 X Y])

(.GETPROPLIST
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:07 by amd")
                                                             (* ; "lmm: 21-JUN-76 2 48")
    (GETPROPLIST X])

(.SETPROPLIST
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:07 by amd")
                                                             (* ; "lmm: 21-JUN-76 2 53")
    (SETPROPLIST X Y])

(.FGETD
  [LAMBDA (X)
    (FGETD X])

(..FRPLNODE2
  [LAMBDA (L M)                                          (* ; "Edited  8-Apr-88 13:07 by amd")
    (FRPLNODE2 L M])

(!AND
  [LAMBDA (A B C)                                        (* ; "Edited  8-Apr-88 13:07 by amd")
    (LIST (AND A B)
          (COND
             ((AND A B)
              1)
             (T 2))
          (COND
             ((NOT (AND A B))
              3)
             (T 4))
          (AND (AND A B)
               5)
          (OR (AND A B)
              6)
          (PROG1 7 (AND A B (SETQ C 9)))
          C])

(!OR
  [LAMBDA (A B C)                                        (* ; "Edited  8-Apr-88 13:07 by amd")
    (LIST (OR A B)
          (COND
             ((OR A B)
              1)
             (T 2))
          (COND
             ((NOT (OR A B))
              3)
             (T 4))
          (OR (OR A B)
              5)
          (OR (OR A B)
              6)
          (PROG1 7 (OR A B (SETQ C 9)))
          C])
)

(RPAQQ TESTMORE
       [(SETPROPLIST 'TESTATOM '(A D))
        [TESTVALS (.NCONC (LIST 1 2 3)
                         (LIST 4 5 6))
               '(1 2 3 4 5 6)
               (.NCONC NIL 'A)
               'A
               (CDR NIL)
               NIL
               (..NCONC (LIST 1 2 3)
                      (LIST 4 5 6))
               '(1 2 3 4 5 6)
               (.AND T T T 3)
               3
               [.AND NIL '(PRINT '(.AND failed]
               NIL
               (.FRPLNODE (CONS)
                      2 3)
               '(2 . 3)
               (.OR 1 2 3)
               1
               (.FRPLNODE2 (CONS 'A 'B)
                      (CONS 'C 'D))
               '(C . D)
               (..FRPLNODE2 (CONS 'A 'B)
                      '(NIL))
               '(NIL)
               (.NCONC3 (LIST 1)
                      (LIST 2)
                      (LIST 3)
                      (LIST 4))
               '(1 2 3 4)
               (..NCONC3 (LIST 1)
                      (LIST 2)
                      (LIST 3)
                      (LIST 4))
               '(1 2 3)
               (LIST (SELECTTEST NIL)
                     (SELECTTEST 1)
                     (SELECTTEST 0)
                     (SELECTTEST 'A)
                     (SELECTTEST 'C))
               '(NIL 1 0 A C)
               (.MKLIST)
               NIL
               (.MKLIST 3)
               '(3)
               (.MKLIST '(3))
               '(3)
               (.EQMEMB 1 1)
               T
               (.EQMEMB 1 '(1))
               T
               (.EQMEMB 'A 'TESTATOM)
               NIL
               (.EQMEMB 'A '(D E F))
               NIL
               (.NCONC1 (LIST 1 2 3)
                      4)
               '(1 2 3 4)
               (LIST (!AND 1 2)
                     (!AND NIL 2)
                     (!AND 1 NIL)
                     (!AND NIL NIL))
               '((2 1 4 5 2 7 9)
                 (NIL 2 3 NIL 6 7 NIL)
                 (NIL 2 3 NIL 6 7 NIL)
                 (NIL 2 3 NIL 6 7 NIL))
               (LIST (!OR 1 2)
                     (!OR NIL 2)
                     (!OR 1 NIL)
                     (!OR NIL NIL))
               '((1 1 4 1 1 7 NIL)
                 (2 1 4 2 2 7 NIL)
                 (1 1 4 1 1 7 NIL)
                 (NIL 2 3 5 6 7 9]
        (SETPROPLIST 'TESTATOM '(A B C D E F))
        (TESTIFSAME (.SETPROPLIST SETPROPLIST 'TESTATOM '(D E F G))
               (.GETPROPLIST GETPROPLIST 'TESTATOM)
               (.FGETD FGETD 'CONS])
(DEFINEQ

(!ADD1VAR
  [NLAMBDA (ADD1X)                                       (* ; "Edited  8-Apr-88 13:07 by amd")
          (* ;; "COMPILES OPEN")

    (DECLARE (LOCALVARS . T))
    (SET ADD1X (ADD1 (EVALV ADD1X])

(!APPEND
  [LAMBDA L                                              (* ; "Edited  8-Apr-88 13:08 by amd")
                                                             (* ; "lmm: 2-JUL-76 4 3")
    (SELECTQ L
        (0 NIL)
        (1 (APPEND2 (ARG L 1)
                  NIL))
        (2 (APPEND2 (ARG L 1)
                  (ARG L 2)))
        (PROG ((V (ARG L L))
               (I L))
          LP  (COND
                 ((ZEROP (SETQ I (SUB1 I)))
                  (RETURN V))
                 (T (SETQ V (APPEND2 (ARG L I)
                                   V))
                    (GO LP])

(APPEND2
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:08 by amd")
                                                             (* ; "lmm: 2-JUL-76 4 1")
    (COND
       ((NLISTP X)
        Y)
       (T (CONS (CAR X)
                (APPEND2 (CDR X)
                       Y])

(!ASSOC
  [LAMBDA (KEY LST)                                      (* ; "Edited  8-Apr-88 13:08 by amd")
                                                             (* ; "lmm: 6-JUL-76 20 11")
          (* ;; "BYTECODE")

    (COND
       ((NLISTP LST)
        NIL)
       ((EQ KEY (CAAR LST))
        (CAR LST))
       (T (!ASSOC KEY (CDR LST])

(!ATTACH
  [LAMBDA (X LST)                                        (* ; "Edited  8-Apr-88 13:09 by amd")
          (* ;; "MSOPVAL COPY CAR COPY1 CDR CONS RPLACD SWAP FRPLACA")

    (RPLNODE LST X (CONS (CAR LST)
                         (CDR LST])

(!CHANGEPROP
  [LAMBDA (X PROP1 PROP2)                                (* ; "Edited  8-Apr-88 13:09 by amd")
          (* ;; "FMEMB !!! UGH")

    (COND
       ((SETQ PROP1 (FMEMB PROP1 (GETPROPLIST X)))
        (FRPLACA PROP1 PROP2)
        X])

(!COPY
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:09 by amd")
                                                             (* ; "lmm: 6-JUL-76 20 12")
          (* ;; "COLLECT?")

    (COND
       ((NLISTP X)
        X)
       (T (CONS (!COPY (CAR X))
                (!COPY (CDR X])

(!DEFLIST
  [LAMBDA (L PROP)                                       (* ; "Edited  8-Apr-88 13:09 by amd")
                                                             (* ; "lmm: 6-JUL-76 20 12")
    (COND
       ((NLISTP L)
        NIL)
       (T (PUTPROP (CAAR L)
                 PROP
                 (CADAR L))
          (!DEFLIST (CDR L)
                 PROP])

(!DREMOVE
  [LAMBDA (X L)                                          (* ; "Edited  8-Apr-88 13:10 by amd")
                                                             (* ; "lmm: 6-JUL-76 20 12")
    (COND
       ((NLISTP L)
        NIL)
       [(EQ X (CAR L))
        (COND
           ((CDR L)
            (!DREMOVE X (FRPLNODE L (CADR L)
                                   (CDDR L]
       (T (* ;; "GET RID OF PROG AND RECURSE?")
          (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)
    (DREV L NIL])

(DREV
  [LAMBDA (L Z)                                          (* ; "Edited  8-Apr-88 13:10 by amd")
    (PROG (Y)
      R1  (COND
             ((NLISTP (SETQ Y L))
              (RETURN Z)))
          (SETQ L (CDR L))
          (SETQ Z (FRPLACD Y Z))
          (GO R1])

(!DSUBST
  [LAMBDA (X Y Z)                                        (* ; "Edited  8-Apr-88 13:10 by amd")
                                                             (* ; "lmm: 2-JUL-76 17 20")
    (COND
       ((EQ Y Z)
        (COPY X))
       ((NLISTP Z)
        Z)
       (T [COND
             ((EQUAL Y (CAR Z))
              (FRPLACA Z (COPY X)))
             (T (!DSUBST X Y (CAR Z]
          (COND
             ((AND Y (EQUAL Y (CDR Z)))
              (FRPLACD Z (COPY X)))
             (T (!DSUBST X Y (CDR Z))
                Z])

(!EVERY
  [LAMBDA (EVERYX EVERYFN1 EVERYFN2)
    (COND
       ((NLISTP EVERYX)
        T)
       ((NULL (APPLY* EVERYFN1 (CAR EVERYX)
                     EVERYX))
        NIL)
       (T (!EVERY (APPLY* (OR EVERYFN2 'CDR)
                             EVERYX)
                 EVERYFN1 EVERYFN2])

(!GETP
  [LAMBDA (ATM PROP)                                     (* ; "Edited  8-Apr-88 13:11 by amd")
          (* ;; "HAS BYTE CODE")

    (AND (LITATOM ATM)
         (PROG NIL
               (SETQ ATM (GETPROPLIST ATM))
           LOOP
               [COND
                  ((OR (NLISTP ATM)
                       (NLISTP (CDR ATM)))
                   (RETURN NIL))
                  ((EQ (CAR ATM)
                       PROP)
                   (RETURN (CADR ATM]
               (SETQ ATM (CDDR ATM))
               (GO LOOP])

(!INTERSECTION
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:11 by amd")
                                                             (* ; "lmm: 6-JUL-76 20 8")
    (AND (LISTP X)
         (COND
            ([AND (MEMBER (CAR X)
                         Y)
                  (NOT (MEMBER (CAR X)
                              (CDR X]
             (CONS (CAR X)
                   (!INTERSECTION (CDR X)
                          Y)))
            (T (!INTERSECTION (CDR X)
                      Y])

(!LAST
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:11 by amd")
          (* ;; "BYTE CODE")

    (COND
       ((NLISTP X)
        X)
       ((NLISTP (CDR X))
        X)
       (T (!LAST (CDR X])

(!LASTN
  [LAMBDA (L N)                                          (* ; "Edited  8-Apr-88 13:38 by amd")
          (* ;; "UGH! NCONC1 SHOULD BE COLLECT")

    (AND (LISTP L)
         (PROG ((X (FNTH L N))
                Y)
               (COND
                  ((NULL X)
                   (RETURN)))
           LP  [COND
                  ((NULL (SETQ X (CDR X)))
                   (RETURN (CONS Y L]
               (SETQ Y (NCONC1 Y (CAR L)))
               (SETQ L (CDR L))
               (GO LP])

(!LDIFF
  [LAMBDA (X Y Z)                                        (* ; "Edited  8-Apr-88 13:12 by amd")
                                                             (* ; "lmm: 6-JUL-76 20 10")
    (COND
       ((EQ X Y)
        Z)
       (Z (NCONC Z (!LDIFF X Y)))
       ((NULL Y)
        X)
       ((NLISTP X)
        (ERROR '"LDIFF: not a tail" Y))
       (T (CONS (CAR X)
                (!LDIFF (CDR X)
                       Y])

(!LENGTH
  [LAMBDA (L)                                            (* ; "Edited  8-Apr-88 13:12 by amd")
          (* ;; "BYTE CODE")

    (COND
       ((NLISTP L)
        0)
       (T (ADD1 (LENGTH (CDR L])

(!LISTGET
  [LAMBDA (LST PROP)                                     (* ; "Edited  8-Apr-88 13:12 by amd")
                                                             (* ; "lmm: 6-JUL-76 20 13")
          (* ;; "BYTE CODE")
          (* ;; "like getp but works on lists, searching them two cdrs at a time.")

    (AND (LISTP LST)
         (COND
            ((EQ PROP (CAR LST))
             (CADR LST))
            (T (!LISTGET (CDDR LST)
                      PROP])

(!LSUBST
  [LAMBDA (X Y Z)                                        (* ; "Edited  8-Apr-88 13:12 by amd")
                                                             (* ; "lmm: 2-JUL-76 16 25")
          (* ;; "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 Z)
        NIL)
       ((NLISTP Z)
        (COND
           ((EQ Y Z)
            X)
           (T Z)))
       [(EQUAL Y (CAR Z))
        (NCONC (COPY X)
               (!LSUBST X Y (CDR Z]
       (T (CONS (!LSUBST X Y (CAR Z))
                (!LSUBST X Y (CDR Z])

(!MAP
  [LAMBDA (MAPX MAPFN1 MAPFN2)                           (* ; "Edited  8-Apr-88 13:13 by amd")
                                                             (* ; "lmm: 6-JUL-76 20 5")
    (COND
       ((NLISTP MAPX)
        NIL)
       (T (APPLY* MAPFN1 MAPX)
          (!MAP (COND
                       (MAPFN2 (APPLY* MAPFN2 MAPX))
                       (T (CDR MAPX)))
                 MAPFN1 MAPFN2])

(!GET
  [LAMBDA (LST PROP)                                     (* ; "Edited  8-Apr-88 13:13 by amd")
          (* ;; "GIVE IT A MACRO")

    (CADR (MEMB PROP LST])

(!GETLIS
  [LAMBDA (X PROPS)
    (PROG [(Z (COND
                 ((LITATOM X)
                  (GETPROPLIST X))
                 (T X]
      LP  (COND
             ((OR (NLISTP Z)
                  (FMEMB (CAR Z)
                         PROPS))
              (RETURN Z)))
          (SETQ Z (CDR Z))
          (GO LP])

(!MEMB
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:13 by amd")
                                                             (* ; "lmm: 6-JUL-76 20 15")
    (COND
       ((NLISTP Y)
        NIL)
       ((EQ X (CAR Y))
        Y)
       (T (!MEMB X (CDR Y])

(!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])

(.COLLCT
  [LAMBDA (X Y)                                              (* lmm%: 28-JUN-76 12 45)
    (COLLCT X Y])

(.ENDCOLLCT
  [LAMBDA (Y)                                                (* lmm%: 28-JUN-76 12 44)
    (ENDCOLLCT Y])

(MYAPPEND1
  [LAMBDA (X Y)                                          (* lmm%: "14-AUG-76 22:32:20")
    (COND
       ((NLISTP X)
        Y)
       (T (CONS (CAR X)
                (MYAPPEND1 (CDR X)
                       Y])

(MYAPPEND2
  [LAMBDA (X Y)                                              (* lmm%: 30-JUN-76 16 57)
    (PROG (V)
      LP  (COND
             ((NLISTP X)
              (RETURN (ENDCOLLCT V Y)))
             (T (SETQ V (COLLCT V (CAR X)))
                (SETQ X (CDR X))
                (GO LP])

(COLLCT
  [LAMBDA (LST NEWITEM)                                      (* lmm%: 28-JUN-76 10 47)
    (COND
       ((NULL LST)
        (RPLACD (SETQ LST (LIST NEWITEM))
               LST))
       (T (CDR (RPLACD LST (CONS NEWITEM (CDR LST])

(ENDCOLLCT
  [LAMBDA (X Y)                                              (* lmm%: 30-JUN-76 16 19)
    (PROG1 (CDR X)
           (FRPLACD X Y])

(.ATTACH
  [LAMBDA (X Y)                                              (* lmm%: 28-JUN-76 13 10)
    (ATTACH X Y])

(.APPEND0
  [LAMBDA NIL                                                (* lmm%: 2-JUL-76 14 22)
    (APPEND])

(.APPEND1
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:13 by amd")
                                                             (* ; "lmm: 2-JUL-76 14 23")
    (APPEND X])

(.APPEND2
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:13 by amd")
                                                             (* ; "lmm: 2-JUL-76 14 23")
    (APPEND X Y])

(.APPEND3
  [LAMBDA (X Y Z)                                        (* ; "Edited  8-Apr-88 13:14 by amd")
                                                             (* ; "lmm: 2-JUL-76 14 23")
    (APPEND X Y Z])

(.APPEND4
  [LAMBDA (X Y Z W)                                      (* ; "Edited  8-Apr-88 13:14 by amd")
                                                             (* ; "lmm: 2-JUL-76 14 23")
    (APPEND X Y Z W])

(.MAPCGETP
  [LAMBDA (AT PROP FN)                                   (* ; "Edited  8-Apr-88 13:14 by amd")
                                                             (* ; "lmm: 7-JUL-76 1 22")
    (MAPC (GETP AT PROP)
          (FUNCTION (LAMBDA (X)
                      (APPLY* FN X])
)

(RPAQQ TESTMISC
       ((TESTVALS (PROGN (SETQ TESTATOM 3)
                         (!ADD1VAR TESTATOM)
                         TESTATOM)
               4
               (!APPEND '(A B C)
                      '(D E F)
                      '(G H I))
               '(A B C D E F G H I)
               (!APPEND '(A B C))
               '(A B C)
               [!ASSOC 0 '((3 . 2)
                           (0 . 1]
               '(0 . 1)
               [!ASSOC 3 '((1 . 2)
                           (2 . 3]
               NIL
               (!ATTACH NIL T)
               '(:ERROR "T is not a LIST.")
               (!ATTACH 'A (LIST 1 2 3))
               '(A 1 2 3)
               [PROGN (SETPROPLIST 'TESTATOM (LIST 1 2 3 4))
                      (!CHANGEPROP 'TESTATOM '3 '10)
                      (LIST (!GETP 'TESTATOM 3)
                            (!GETP 'TESTATOM 10)
                            (!GETP 'TESTATOM 1)
                            (GETPROPLIST 'TESTATOM]
               '(NIL 4 2 (1 2 10 4))
               (!COPY '(A 1 1.3 "FOO" . XX))
               '(A 1 1.3 "FOO" . XX)
               [!COPY '((A . 3)
                        (B C 10 3 . 10]
               '((A . 3)
                 (B C 10 3 . 10))
               (!DREMOVE 3 (LIST 3 1 3 5 7))
               '(1 5 7)
               [!DSUBST 3 10 (!COPY '((A . 3)
                                      (B C 10 3 . 10)
                                      (10 . A) . A]
               '((A . 3)
                 (B C 3 3 . 3)
                 (3 . A) . A)
               (!EVERY '(1 NIL 2 NIL 4 NIL)
                      'SMALLP
                      'CDDR)
               T
               (!EVERY '(A B C . 3)
                      'LITATOM)
               T
               (!EVERY '(1 2 3 A)
                      'SMALLP)
               NIL
               (!GET '(A B C D E)
                     'A)
               'B
               (!GET '(A B C D E)
                     'B)
               'C
               (!GETLIS '(A B C D E)
                      '(1 3 B))
               '(B C D E)
               [PROGN (!DEFLIST '((FOO FIE)
                                  (FUM FEE))
                             'PROPNAME)
                      (LIST (GETP 'FOO 'PROPNAME)
                            (GETP 'FUM 'PROPNAME]
               '(FIE FEE)
               (LIST (!DREVERSE (SETQ A (LIST 1 2 3 4 5)))
                     A)
               '((5 4 3 2 1)
                 (1))
               (!GET '(A B C . D)
                     'A)
               'B
               (!INTERSECTION '(1 3 2 4)
                      '(4 2 1))
               '(1 2 4)
               [LIST (!LAST 3)
                     (!LAST '(A . B))
                     (!LAST '(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 1 2 3 4 5 6 7 8 9 0
                                ! @ %# $ %% ~ & * %( %) - = + \ %| %[ %] { } _ ^ %: ; %' %" %, < > %.
                                ? / END]
               '(3 (A . B)
                   (END))
               (!LASTN (LIST 1 2 3 4 5)
                      1)
               '((1 2 3 4)
                 5)
               (!LASTN (LIST 1 2 3)
                      0)
               '((1 2 3))
               (!LDIFF (SETQ A '(A B C D E F G H))
                      (!NTH A 4))
               '(A B C)
               (!LENGTH T)
               0
               (!LENGTH '(A B C D E F))
               6
               (!LISTGET '(A B C D)
                      'B)
               NIL
               (!LISTGET '(A B C D E)
                      'A)
               'B
               [!LSUBST '(A B C)
                      'D
                      (!COPY '((3 . D)
                               (D . 3)
                               (X D Y]
               '((3 A B C)
                 (A B C . 3)
                 (X A B C Y))
               (PROG ((V 0))
                     (RETURN (LIST [!MAP '(1 2 3 4)
                                         (FUNCTION (LAMBDA (X)
                                                          (SETQ V (IPLUS V (CAR X]
                                   V)))
               '(NIL 10))
        (TESTVALS (ENDCOLLCT (COLLCT (COLLCT (COLLCT NIL 'A)
                                            10)
                                    14))
               '(A 10 14)
               (ENDCOLLCT (.COLLCT (.COLLCT (.COLLCT NIL 'A)
                                          10)
                                 14))
               '(A 10 14)
               (.ENDCOLLCT (.COLLCT (.COLLCT (.COLLCT NIL 'A)
                                           10)
                                  14))
               '(A 10 14)
               (MYAPPEND1 '(A B C)
                      '(D E F))
               '(A B C D E F)
               (MYAPPEND2 (LIST 1 2 3)
                      (LIST 4 5 6))
               '(1 2 3 4 5 6)
               (.ATTACH 1 (LIST 2 3 4 5))
               '(1 2 3 4 5)
               (.APPEND1 '(A B C))
               '(A B C)
               (.APPEND2 '(A B C)
                      '(D E F))
               '(A B C D E F)
               (.APPEND3 '(A B)
                      '(C D)
                      '(E F))
               '(A B C D E F)
               (.APPEND4 '(A B)
                      NIL
                      '(C D)
                      NIL)
               '(A B C D)
               (PROG ((S 0))
                     (PUT 'A 'B '(1 2 3 4 5))
                     [.MAPCGETP 'A 'B (FUNCTION (LAMBDA (X)
                                                       (SETQ S (IPLUS X S]
                     (RETURN S))
               15)))
(DEFINEQ

(.MAP
  [LAMBDA (X Y Z)                                        (* ; "Edited  8-Apr-88 13:14 by amd")
    (LIST 1 (PROG ((C 0))
                  [MAP X (FUNCTION (LAMBDA (Y)
                                     (SETQ C (IPLUS (LENGTH Y)
                                                    C]
                  (RETURN C))
          7])

(.MAPC
  [LAMBDA (X Y Z)
    (LIST 1 (PROG ((C 0))
                  [MAPC X (FUNCTION (LAMBDA (Y)
                                      (SETQ C (IPLUS Y C]
                  (RETURN C))
          (COND
             ((PROG ((C 0))
                    [MAPC X (FUNCTION (LAMBDA (Y)
                                        (SETQ C (IPLUS Y C]
                    (RETURN C))
              2)
             ((NOT (PROG ((C 0))
                         [MAPC X (FUNCTION (LAMBDA (Y)
                                             (SETQ C (IPLUS Y C]
                         (RETURN C)))
              3)
             (T 4))
          (OR (PROG ((C 0))
                    [MAPC X (FUNCTION (LAMBDA (Y)
                                        (SETQ C (IPLUS Y C]
                    (RETURN C))
              5)
          (AND (PROG ((C 0))
                     [MAPC X (FUNCTION (LAMBDA (Y)
                                         (SETQ C (IPLUS Y C]
                     (RETURN C))
               6)
          (PROGN (PROG ((C 0))
                       [MAPC X (FUNCTION (LAMBDA (Y)
                                           (SETQ C (IPLUS Y C]
                       (RETURN C))
                 7])

(.MAPCEFF
  [LAMBDA (X Y Z)                                        (* ; "Edited  8-Apr-88 13:14 by amd")
    (LIST 1 (PROGN (PROG ((C 0))
                         [MAPC X (FUNCTION (LAMBDA (Y)
                                             (SETQ C (IPLUS Y C]
                         (RETURN C))
                   7])
)

(RPAQQ TESTMAP
       [(TESTVALS (.MAP)
               '(1 0 7)
               (.MAP '(1 2 3 4 5))
               '(1 15 7))
        (TESTVALS (.MAPC '(1 2 3 4))
               '(1 10 2 10 6 7)
               (.MAPCEFF)
               '(1 7])
(DEFINEQ

(.FPLUS
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:14 by amd")
                                                             (* ; "lmm: 22-JUN-76 0 39")
          (* ;; "subr")

    (FPLUS X Y])

(.FTIMES
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:15 by amd")
                                                             (* ; "lmm: 22-JUN-76 0 40")
          (* ;; "SUBR*")

    (FTIMES X Y])

(.FDIFFERENCE
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:15 by amd")
                                                             (* ; "lmm: 22-JUN-76 0 40")
          (* ;; "CEXPR")

    (FDIFFERENCE X Y])

(.FQUOTIENT
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:15 by amd")
                                                             (* ; "lmm: 22-JUN-76 0 40")
    (FQUOTIENT X Y])
)

(RPAQQ TESTLINK ((TESTIFSAME (.FPLUS FPLUS 2 10)
                            (.FTIMES FTIMES 3 5)
                            (.FDIFFERENCE FDIFFERENCE 4.5 7.9)
                            (.FQUOTIENT FQUOTIENT 4.5 10.3))))
(DEFINEQ

(NONLOCALGO
  [LAMBDA (A B C)                                        (* ; "Edited  8-Apr-88 13:15 by amd")
                                                             (* ; "lmm: 28-JUN-76 14 9")
    (LIST -2 -1 (PROG ((C 1)
                       (D 2)
                       (E 3)
                       F)
                      (SETQ F (LIST C D E))
                      [RETURN (PROG ((G 13)
                                     (H 14)
                                     (I 15))
                                    (RETURN (LIST G H I (PROG ((I H)
                                                               (H I))
                                                              (COND
                                                                 (F (GO POPOUT)))
                                                              (RETURN (LIST I H]
                  POPOUT
                      (RETURN (LIST D E F])

(CNTDWN
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:15 by amd")
                                                             (* ; "lmm: 21-JUN-76 3 54")
    (PROG NIL
      LP  (SELECTQ X
              (0 (RETURN))
              (PROGN (SETQ X (SUB1 X))
                     (GO LP])

(JUMPAROUND
  [LAMBDA NIL                                            (* ; "Edited  8-Apr-88 13:15 by amd")
                                                             (* ; "lmm: 22-JUN-76 1 23")
    (COND
       (NIL T)
       (T NIL])
)

(RPAQQ TESTJUMP ([TESTVALS (NONLOCALGO)
                            '(-2 -1 (2 3 (1 2 3]
                     (TESTVALS (CNTDWN 0)
                            NIL)
                     (TESTVALS (CNTDWN 20)
                            NIL)))
(DEFINEQ

(FN2
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:16 by amd")
                                                             (* ; "lmm: 19-JUN-76 2 6")
    (LIST3 X Y])

(FN3
  [LAMBDA (X Y Z)                                        (* ; "Edited  8-Apr-88 13:16 by amd")
                                                             (* ; "lmm: 19-JUN-76 1 53")
    (LIST3 X Y Z])

(FN1
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:16 by amd")
                                                             (* ; "lmm: 19-JUN-76 2 8")
    (LIST3 X])

(.IVAR
  [LAMBDA (A B C D E F G H I J K L M N O)                (* ; "Edited  8-Apr-88 13:16 by amd")
                                                             (* ; "lmm: 19-JUN-76 2 12")
    (IVAR A B C D E F G H I J K L M N O])
)

(RPAQQ TESTFNX
       [(TESTVALS (FN3 1 2 3)
               '(1 2 3)
               (FN2 1 2)
               '(1 2 NIL)
               (FN1 1)
               '(1 NIL NIL)
               (.IVAR 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
               '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15])
(DEFINEQ

(.GETP
  [LAMBDA (X Y)
    (GETP X Y])

(.GETPROP
  [LAMBDA (X Y)
    (GETPROP X Y])

(.RPLACA
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:17 by amd")
                                                             (* ; "lmm: 18-JUN-76 14 22")
    (RPLACA X Y])

(.RPLACD
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:17 by amd")
                                                             (* ; "lmm: 18-JUN-76 14 22")
    (RPLACD X Y])

(.FRPLACA
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:17 by amd")
                                                             (* ; "lmm: 18-JUN-76 14 46")
    (FRPLACA X Y])

(.GET
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:17 by amd")
    (LISTGET X Y])

(.FRPLACD
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:17 by amd")
                                                             (* ; "lmm: 18-JUN-76 14 47")
    (FRPLACD X Y])

(.ASSOC
  [LAMBDA (X Y)
    (ASSOC X Y])

(.LENGTH
  [LAMBDA (X)
    (LENGTH X])

(.LAST
  [LAMBDA (X)
    (LAST X])

(.GETHASH
  [LAMBDA (X Y)
    (GETHASH X Y])

(.FMEMB
  [LAMBDA (X Y)
    (FMEMB X Y])
)

(RPAQQ TESTFN
       [[SETPROPLIST (PUTHASH 1 'TESTATOM (SETQ TARRAY (HARRAY 10)))
               (PUTHASH 3 '(A (B)
                              C D E F G (H]
        (SETQQ LONGLIST TESTATOM)
        (RPTQ 2048 (SETQ LONGLIST (CONS T LONGLIST)))
        (TESTIFSAME (.GETP GETP 'TESTATOM 'A)
               (.GETPROP GETP 'TESTATOM 'B)
               (.GETP GETP 3 NIL)
               (.RPLACA RPLACA (CONS 'A 'B)
                      'C)
               (.RPLACA RPLACA NIL T)
               (.RPLACA RPLACA NIL NIL)
               (.RPLACA RPLACA "foo" "fum")
               (.RPLACD RPLACD (CONS 'A 'B)
                      'C)
               (.FRPLACA FRPLACA (CONS 'A 'B)
                      'C)
               (.FRPLACD FRPLACD (CONS 'A 'B)
                      'C)
               (.GET LISTGET '(A B C . 3)
                     'C)
               (.GET LISTGET '(A B C . TESTATOM)
                     'A)
               (.GET LISTGET '(A B C . TESTATOM)
                     'D)
               (.GET LISTGET 'TESTATOM 'D)
               (.LENGTH LENGTH '(1 3 . 4))
               (.LENGTH LENGTH LONGLIST)
               (.ASSOC ASSOC '((A . B)
                               (C . D))
                      'A)
               (.ASSOC ASSOC 'TESTATOM 'H)
               (.LAST LAST LONGLIST)
               (.GETHASH GETHASH 3)
               (.GETHASH GETHASH 1 TARRAY)
               (.FGETD FGETD 'RECLAIM)
               (.FGETD FGETD '.FGETD)
               (.FMEMB FMEMB 'A '(D B C A))
               (.FMEMB FMEMB 'A '(D B C])

(RPAQQ TESTEDIT
       [(TESTVALS [EDITE (LIST 1 2 3 4)
                         '((1)
                           (N 5)
                           (2 (F (G H)))
                           F F (SW 1 2)
                           ^ F H !0 (1 P]
               '(2 ((P H)
                    F)
                   4 5])
(DEFINEQ

(.CONS
  [LAMBDA (A B)
    (CONS A B])

(LIST0
  [LAMBDA NIL                                            (* ; "Edited  8-Apr-88 13:18 by amd")
                                                             (* ; "lmm: 21-JUN-76 15 57")
    (LIST])

(LIST1
  [LAMBDA (X)
    (LIST X])

(LIST2
  [LAMBDA (A B)
    (LIST A B])

(LIST3
  [LAMBDA (X Y Z)
    (LIST X Y Z])

(LIST4
  [LAMBDA (A B C D)                                      (* ; "Edited  8-Apr-88 13:18 by amd")
                                                             (* ; "lmm: 21-JUN-76 15 56")
    (LIST A B C D])

(LIST5
  [LAMBDA (A B C D E)                                    (* ; "Edited  8-Apr-88 13:18 by amd")
                                                             (* ; "lmm: 21-JUN-76 15 56")
    (LIST A B C D E])

(LIST6
  [LAMBDA (A B C D E F)                                  (* ; "Edited  8-Apr-88 13:18 by amd")
                                                             (* ; "lmm: 21-JUN-76 15 57")
    (LIST A B C D E F])

(LIST7
  [LAMBDA (A B C D E F G)                                (* ; "Edited  8-Apr-88 13:18 by amd")
                                                             (* ; "lmm: 21-JUN-76 15 57")
    (LIST A B C D E F G])

(LIST8
  [LAMBDA (A B C D E F G H)                              (* ; "Edited  8-Apr-88 13:19 by amd")
                                                             (* ; "lmm: 21-JUN-76 15 57")
    (LIST A B C D E F G H])

(LIST9
  [LAMBDA (A B C D E F G H I)                            (* ; "Edited  8-Apr-88 13:19 by amd")
                                                             (* ; "lmm: 21-JUN-76 15 57")
    (LIST A B C D E F G H I])

(LIST10
  [LAMBDA (A B C D E F G H I J)                          (* ; "Edited  8-Apr-88 13:19 by amd")
                                                             (* ; "lmm: 25-JUN-76 5 18")
    (LIST A B C D E F G H I J])

(LIST11
  [LAMBDA (A B C D E F G H I J K)                        (* ; "Edited  8-Apr-88 13:19 by amd")
                                                             (* ; "lmm: 25-JUN-76 5 19")
    (LIST A B C D E F G H I J K])

(LIST12
  [LAMBDA (A B C D E F G H I J K L)                      (* ; "Edited  8-Apr-88 13:19 by amd")
                                                             (* ; "lmm: 28-JUN-76 8 3")
    (LIST A B C D E F G H I J K L])

(LIST13
  [LAMBDA (A B C D E F G H I J K L M)                    (* ; "Edited  8-Apr-88 13:19 by amd")
                                                             (* ; "lmm: 28-JUN-76 8 3")
    (LIST A B C D E F G H I J K L M])
)

(RPAQQ TESTCONS
       [(TESTVALS (.CONS 10 12)
               '(10 . 12)
               (LIST0)
               NIL
               (LIST1 1)
               '(1)
               (LIST2 1 2)
               '(1 2)
               (LIST3 1 2 3)
               '(1 2 3)
               (LIST4 1 2 3 4)
               '(1 2 3 4)
               (LIST5 1 2 3 4 5)
               '(1 2 3 4 5)
               (LIST6 1 2 3 4 5 6)
               '(1 2 3 4 5 6)
               (LIST7 1 2 3 4 5 6 7)
               '(1 2 3 4 5 6 7)
               (LIST8 1 2 3 4 5 6 7 8)
               '(1 2 3 4 5 6 7 8)
               (LIST9 1 2 3 4 5 6 7 8 9)
               '(1 2 3 4 5 6 7 8 9)
               (LIST10 10 9 8 7 6 5 4 3 2 1)
               '(10 9 8 7 6 5 4 3 2 1)
               (LIST11 1 2 6 3 7 4 8 5 9 10 11)
               '(1 2 6 3 7 4 8 5 9 10 11])
(DEFINEQ

(.CAR
  [LAMBDA (X)
    (CAR X])

(.CDR
  [LAMBDA (X)
    (CDR X])

(.CAAR
  [LAMBDA (X)
    (CAAR X])

(.CDAR
  [LAMBDA (X)
    (CDAR X])

(.CADR
  [LAMBDA (X)
    (CADR X])

(.CDDR
  [LAMBDA (X)
    (CDDR X])

(.CAAAAR
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:20 by amd")
                                                             (* ; "lmm: 19-JUN-76 20 57")
    (CAR (CAAR (CAR X])
)

(RPAQQ TESTCAR
       ((TESTVALS (.CAR '(A))
               'A
               (.CDR '(A . B))
               'B
               [.CAAR '((A]
               'A
               [.CDAR '((A . B]
               'B
               (.CADR '(A B))
               'B
               (.CDDR '(A B . C))
               'C
               [.CAAAAR '((((A]
               'A)))
(DEFINEQ

(.LAM0
  [LAMBDA NIL
    (LAM0])

(..LAM0
  [LAMBDA NIL
    (LAM0 T T T T T T])

(.LAM1
  [LAMBDA NIL
    (LAM1])

(..LAM1
  [LAMBDA NIL
    (LAM1 -372 "extra args" "should be ignored"])

(.NLAML
  [LAMBDA NIL
    (NLAML the NLAMBDA bit should make no difference])

(LAM1LOC
  [LAMBDA (X)
    (DECLARE (LOCALVARS X))
    X])
)

(RPAQQ TESTCALL
       ((TESTVALS (LAM0)
               NIL
               (.LAM0)
               NIL
               (LAM0 T T T T T)
               NIL
               (..LAM0)
               NIL
               (LAM1)
               NIL
               (.LAM1)
               NIL
               (LAM1 -372 "extra args" "should be ignored")
               -372
               (..LAM1)
               -372
               (NLAML the NLAMBDA bit should make no difference)
               'the
               (.NLAML)
               'the
               (LAM1LOC)
               NIL
               (LAM1LOC 341)
               341
               (LAM1LOC 27 28 29)
               27)))
(DEFINEQ

(.PROGS
  [LAMBDA (X Y Z)                                        (* ; "Edited  8-Apr-88 13:21 by amd")
    (LIST 1 [PROG (X (Y (CDR Y)))
              LPX (RETURN (LIST 3 (COND
                                     (X (SETQ Z X)
                                        (SETQ X)
                                        (GO LPX))
                                     (Y (SETQ Y NIL)
                                        (RETURN 17))
                                     (T (LIST Z]
          (COND
             ([PROG (X (Y (CDR Y)))
                LPX (RETURN (LIST 3 (COND
                                       (X (SETQ Z X)
                                          (SETQ X)
                                          (GO LPX))
                                       (Y (SETQ Y NIL)
                                          (RETURN 17))
                                       (T (LIST Z]
              2)
             ([NOT (PROG (X (Y (CDR Y)))
                     LPX (RETURN (LIST 3 (COND
                                            (X (SETQ Z X)
                                               (SETQ X)
                                               (GO LPX))
                                            (Y (SETQ Y NIL)
                                               (RETURN 17))
                                            (T (LIST Z]
              3)
             (T 4))
          (OR [PROG (X (Y (CDR Y)))
                LPX (RETURN (LIST 3 (COND
                                       (X (SETQ Z X)
                                          (SETQ X)
                                          (GO LPX))
                                       (Y (SETQ Y NIL)
                                          (RETURN 17))
                                       (T (LIST Z]
              5)
          (AND [PROG (X (Y (CDR Y)))
                 LPX (RETURN (LIST 3 (COND
                                        (X (SETQ Z X)
                                           (SETQ X)
                                           (GO LPX))
                                        (Y (SETQ Y NIL)
                                           (RETURN 17))
                                        (T (LIST Z]
               6)
          (PROGN [PROG (X (Y (CDR Y)))
                   LPX (RETURN (LIST 3 (COND
                                          (X (SETQ Z X)
                                             (SETQ X)
                                             (GO LPX))
                                          (Y (SETQ Y NIL)
                                             (RETURN 17))
                                          (T (LIST Z]
                 7])

(.SPEC
  [LAMBDA (X Y Z)
    (LIST 1 [IDIFFERENCE (CONSCOUNT)
                   (PROG (LISPXHIST)
                         (DECLARE (LOCALVARS . T))
                         (/RPLACA X NIL)
                         (RETURN (CONSCOUNT]
          (COND
             ([IDIFFERENCE (CONSCOUNT)
                     (PROG (LISPXHIST)
                           (DECLARE (LOCALVARS . T))
                           (/RPLACA X NIL)
                           (RETURN (CONSCOUNT]
              2)
             ([NOT (IDIFFERENCE (CONSCOUNT)
                          (PROG (LISPXHIST)
                                (DECLARE (LOCALVARS . T))
                                (/RPLACA X NIL)
                                (RETURN (CONSCOUNT]
              3)
             (T 4))
          (OR [IDIFFERENCE (CONSCOUNT)
                     (PROG (LISPXHIST)
                           (DECLARE (LOCALVARS . T))
                           (/RPLACA X NIL)
                           (RETURN (CONSCOUNT]
              5)
          (AND [IDIFFERENCE (CONSCOUNT)
                      (PROG (LISPXHIST)
                            (DECLARE (LOCALVARS . T))
                            (/RPLACA X NIL)
                            (RETURN (CONSCOUNT]
               6)
          (PROGN [IDIFFERENCE (CONSCOUNT)
                        (PROG (LISPXHIST)
                              (DECLARE (LOCALVARS . T))
                              (/RPLACA X NIL)
                              (RETURN (CONSCOUNT]
                 7])

(.COND
  [LAMBDA (X Y Z)
    (LIST 1 (COND
               (X 1)
               ((NULL X)
                2)
               (T 3))
          (COND
             ((COND
                 (X 1)
                 ((NULL X)
                  2)
                 (T 3))
              2)
             ((NOT (COND
                      (X 1)
                      ((NULL X)
                       2)
                      (T 3)))
              3)
             (T 4))
          (OR (COND
                 (X 1)
                 ((NULL X)
                  2)
                 (T 3))
              5)
          (AND (COND
                  (X 1)
                  ((NULL X)
                   2)
                  (T 3))
               6)
          (PROGN (COND
                    (X 1)
                    ((NULL X)
                     2)
                    (T 3))
                 7])

(.DELBIND
  [LAMBDA (X Y Z)
    (LIST 1 [PROG NIL
                  (RETURN (LIST 10 (COND
                                      (X (RETURN 11]
          (COND
             ([PROG NIL
                    (RETURN (LIST 10 (COND
                                        (X (RETURN 11]
              2)
             ([NOT (PROG NIL
                         (RETURN (LIST 10 (COND
                                             (X (RETURN 11]
              3)
             (T 4))
          (OR [PROG NIL
                    (RETURN (LIST 10 (COND
                                        (X (RETURN 11]
              5)
          (AND [PROG NIL
                     (RETURN (LIST 10 (COND
                                         (X (RETURN 11]
               6)
          (PROGN [PROG NIL
                       (RETURN (LIST 10 (COND
                                           (X (RETURN 11]
                 7])
)

(RPAQQ TESTC2
       [(TESTVALS (.SPEC '(NIL))
               '(1 0 2 0 6 7))
        (TESTVALS (.COND 3)
               '(1 1 2 1 6 7)
               (.COND)
               '(1 2 2 2 6 7))
        (TESTVALS (.DELBIND)
               '(1 (10 NIL)
                   2
                   (10 NIL)
                   6 7)
               (.DELBIND 10)
               '(1 11 2 11 6 7])
(DEFINEQ

(T1
  [LAMBDA (X)
    1])

(T0
  [LAMBDA (X)
    0])

(TT
  [LAMBDA (X)
    T])

(TNIL
  [LAMBDA (X)
    NIL])

(T-1
  [LAMBDA (X)
    -1])

(T2
  [LAMBDA (X)
    2])

(T12
  [LAMBDA (X)
    12])

(T377
  [LAMBDA (X)
    255])

(T400Q
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:22 by amd")
    256])

(T-400
  [LAMBDA (X)
    -256])

(TSTR
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:22 by amd")
    "FOO"])

(.NILARGS
  [LAMBDA (A B C D E F G H I J K L M N O)
    (DECLARE (LOCALVARS . T))
    (AND (OR A B C D E F G H I J K L M N O)
         (FAILTEST])
)

(RPAQQ TESTC
       [(TESTVALS (T1)
               1
               (T0)
               0
               (TT)
               T
               (TNIL)
               NIL
               (T-1)
               -1
               (T2)
               2
               (T12)
               12
               (T377)
               255
               (T400Q)
               256
               (T-400)
               -256
               (TSTR)
               "FOO")
        (PROG [(TEST '(.NILARGS]
              (RPTQ 1000 (.NILARGS])
(DEFINEQ

(.BIND0
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:22 by amd")
    (PROG (Y Z W)
          (RETURN X])

(.BIND1
  [LAMBDA (A B)                                          (* ; "Edited  8-Apr-88 13:23 by amd")
                                                             (* ; "lmm: 22-JUN-76 1 0")
    (DECLARE (SPECVARS . T))
    (PROG ((C 1)
           (D 2))
          (RETURN (PROG (E F (G 3)
                           (H 4))
                        (RETURN (EVALVARS])

(.BIND2
  [LAMBDA (A B)                                          (* ; "Edited  8-Apr-88 13:23 by amd")
                                                             (* ; "lmm: 22-JUN-76 1 0")
    (DECLARE (LOCALVARS . T))
    (PROG ((C 1)
           (D 2))
          (RETURN (PROG (E F (G 3)
                           (H 4))
                        (RETURN (EVALVARS])

(.BIND3
  [LAMBDA (A B)                                          (* ; "Edited  8-Apr-88 13:23 by amd")
                                                             (* ; "lmm: 24-JUN-76 4 57")
    (DECLARE (SPECVARS . T))
    (LIST [PROG ((C 1)
                 (D 2))
                (RETURN (PROG (E F (G 3)
                                 (H 4))
                              (RETURN (EVALVARS]
          A B])

(.BIND4
  [LAMBDA (A B)                                          (* ; "Edited  8-Apr-88 13:23 by amd")
                                                             (* ; "lmm: 24-JUN-76 4 57")
    (DECLARE (SPECVARS . T))
    (LIST [PROG ((C 1)
                 (D 2))
                (RETURN (PROG (E F (G 3)
                                 (H 4))
                              (RETURN (EVALVARS]
          A B])

(.BINDASSOC
  [LAMBDA (V ALST VAR)                                   (* ; "Edited  8-Apr-88 13:23 by amd")
                                                             (* ; "lmm: 24-JUN-76 8 42")
    (PROG ((D (ASSOC V ALST)))
          (RETURN (EVAL VAR])

(.BIND5
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:23 by amd")
                                                             (* ; "lmm: 24-JUN-76 8 51")
    (PROG ((D (CDR X)))
          (PROG ((LC (CDR D)))
                (DECLARE (LOCALVARS LC))
                ([LAMBDA (X)
                   (RETFROM '.BIND5 (EVAL 'X]
                 LC])

(.BINDPOP
  [LAMBDA (X Y)                                          (* ; "Edited  8-Apr-88 13:24 by amd")
                                                             (* ; "lmm: 24-JUN-76 9 40")
    (PROG1 Y (PROG ((K X))
                   (CONS K K)
                   (SETQ Y X])
)

(RPAQQ TESTBIND
       [(TESTVALS (.BIND0 173)
               173
               (.BIND1 1 2 3)
               '(1 2 1 2 NIL NIL 3 4)
               (.BIND2 1 2 3)
               '(A.TOP B.TOP C.TOP D.TOP E.TOP F.TOP G.TOP H.TOP)
               (.BIND3 1 2)
               '((1 2 1 2 NIL NIL 3 4)
                 1 2)
               (.BIND4 1 2 3 4)
               '((1 2 1 2 NIL NIL 3 4)
                 1 2)
               (.BINDASSOC 'A '((A . B))
                      'D)
               '(A . B)
               (.BINDPOP 23 73)
               73
               (.BIND5 '(A B C D E))
               '(C D E])

(RPAQQ TESTAT
       ((TESTVALS (ARGTYPE 'LAM0)
               0
               (NARGS 'LAM0)
               0
               (ARGLIST 'LAM0)
               NIL
               (CALLS 'LAM0)
               '(NIL NIL NIL NIL)
               (FNTYP 'LAM0)
               'CEXPR
               (CCODEP 'LAM0)
               T
               (ARGTYPE 'LAM1)
               0
               (NARGS 'LAM1)
               1
               (ARGLIST 'LAM1)
               '(X)
               (CALLS 'LAM1)
               '(NIL NIL NIL NIL)
               (FNTYP 'LAM1)
               'CEXPR
               (CCODEP 'LAM1)
               T
               (ARGTYPE 'LAMA)
               2
               (NARGS 'LAMA)
               1
               (ARGLIST 'LAMA)
               'U
               (CALLS 'LAMA)
               '(NIL NIL NIL NIL)
               (FNTYP 'LAMA)
               'CEXPR*
               (CCODEP 'LAMA)
               T
               (ARGTYPE 'NLAML)
               1
               (NARGS 'NLAML)
               1
               (ARGLIST 'NLAML)
               '(L)
               (CALLS 'NLAML)
               '(NIL NIL NIL NIL)
               (FNTYP 'NLAML)
               'CFEXPR
               (CCODEP 'NLAML)
               T
               (ARGTYPE 'NLAMA)
               3
               (NARGS 'NLAMA)
               1
               (CALLS 'NLAMA)
               '(NIL NIL NIL NIL)
               (FNTYP 'NLAMA)
               'CFEXPR*
               (CCODEP 'NLAMA)
               T)))
(DEFINEQ

(LAM0
  [LAMBDA NIL NIL])

(LAM1
  [LAMBDA (X)
    (DECLARE (LOCALVARS X))                          (* ; "Edited  8-Apr-88 13:24 by amd")
    X])

(LAMA
  [LAMBDA L
    (DECLARE (SPECVARS L))                           (* ; "Edited  8-Apr-88 13:24 by amd")
    L])

(NLAML
  [NLAMBDA (L)
    (DECLARE (LOCALVARS L))                          (* ; "Edited  8-Apr-88 13:24 by amd")
    L])

(NLAMA
  [NLAMBDA L
    (DECLARE (LOCALVARS L))                          (* ; "Edited  8-Apr-88 13:25 by amd")
    L])
)
(DEFINEQ

(.SELECTQ
  [LAMBDA (A B C)                                        (* ; "Edited  8-Apr-88 13:25 by amd")
    (LIST 3 (PROGN (SELECTQ A
                       (1 (ADD1VAR C))
                       ((2 3 4) 
                            (SUB1VAR C))
                       (5 (SETQ C (CDR C)))
                       NIL)
                   (SELECTQ B
                       (1 (ADD1VAR C))
                       ((2 3 4) 
                            (SUB1VAR C))
                       (5 (SETQ C (CDR C)))
                       NIL))
          (COND
             ((SELECTQ C
                  (NIL T)
                  (0 NIL)
                  (3 (SMALLP B))
                  A)
              22])

(.SUBFNS
  [LAMBDA NIL                                            (* ; "Edited  8-Apr-88 13:25 by amd")
    (LIST [PROG1 'GOOD [SETQ FREE1 (FUNCTION (LAMBDA (X)
                                               (CAR X]
                 [SETQ FREE2 (FUNCTION (LAMBDA N N]
                 (SETQ FREE3 (FUNCTION (NLAMBDA L L]
          (APPLY* FREE1 '(A) '(B))
          (APPLY* FREE2 1 2 3 4 5)
          (APPLY* FREE3 1 2 3 4 5)
          (SUBSET '((NIL)
                    (3)) FREE1])

(.MISC
  [LAMBDA (B C A)                                        (* ; "Edited  8-Apr-88 13:25 by amd")
    (LIST 1 (PROG ((A NIL))
                  (RETURN (PROGN B C A))
                  (FOO BAZ WHAMMY)
                  (PROG (X)
                        (HELP)))
          3])

(.FORTEST
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:25 by amd")
    (for X on (to X collect (to X collect X))
       when (SOME X (FUNCTION CDDR)) collect (CONS X (LENGTH X])

(.BIGCOND
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:25 by amd")
    (COND
       ((LISTP X)
        (LIST X))
       ((ARRAYP X)
        (ELT X 1))
       ((FIXP X)
        (ITIMES (ITIMES 60 24 365)
               X])

(.RECORDTEST
  [LAMBDA (ARG)                                          (* ; "Edited  8-Apr-88 13:26 by amd")
                                                             (* DECLARATIONS%: (RECORD A
                                                           (B . C)))
    (PROG [(ZZ (create A
                      C _ (RPLACA (CONS)
                                 1)
                      B _ (RPLACA (CONS)
                                 2]
          (COND
             (ARG (replace B of ZZ with 17)))
          [RPLACD (fetch C of ZZ)
                 (create A
                        C _ (LIST 4)
                        B _ (COND
                               ((ZEROP ARG)
                                (GO HOME))
                               ((EQ ARG 3)
                                (RETURN ZZ))
                               (T -2]
      HOME
          (RETURN ZZ])

(.PROGRETURN
  [LAMBDA (X)                                            (* ; "Edited  8-Apr-88 13:26 by amd")
    (PROG NIL
          (SETQ X (LIST (LIST 1)
                        (LIST 2)))
          (RPLACD (ASSOC 1 X)
                 T)
          (RETURN (SOME X (FUNCTION LISTP])

(.ALWAYSFALSE
  [LAMBDA (A B)                                          (* ; "Edited  8-Apr-88 13:26 by amd")
    (LIST 1 (COND
               ((COND
                   (A NIL)
                   (B NIL))
                T)
               (T NIL))
          3])

(.ALWAYSTRUE
  [LAMBDA (A B)                                          (* ; "Edited  8-Apr-88 13:26 by amd")
    (COND
       ((COND
           (A T)
           (B T)
           (T T))
        T)
       (T NIL])

(.EQ1
  [LAMBDA (X Y)
    (DECLARE (LOCALVARS X Y))                        (* ; "Edited  8-Apr-88 13:27 by amd")
    (COND
       ((EQ X Y)
        T)
       [(NLISTP X)
        (COND
           ((OR (NUMBERP X)
                (STACKP X))
            (EQP X Y))
           ((STRINGP X)
            (STREQUAL X Y]
       ((LISTP Y)
        (AND (.EQ1 (CAR X)
                    (CAR Y))
             (.EQ1 (CDR X)
                    (CDR Y])

(.EQ2
  [LAMBDA (X Y)
    (DECLARE (LOCALVARS X Y))                        (* ; "Edited  8-Apr-88 13:27 by amd")
    (COND
       [(NEQ X Y)
        (COND
           [(LISTP X)
            (AND (LISTP Y)
                 (.EQ2 (CAR X)
                        (CAR Y))
                 (.EQ2 (CDR X)
                        (CDR Y]
           [(NOT (OR (NUMBERP X)
                     (STACKP X)))
            (COND
               ((STRINGP X)
                (STREQUAL X Y]
           (T (EQP X Y]
       (T T])

(.EQ3
  [LAMBDA (X Y)
    (DECLARE (LOCALVARS X Y))                        (* ; "Edited  8-Apr-88 13:27 by amd")
    (COND
       ((EQ X Y)
        T)
       ((LISTP X)
        (COND
           [(LISTP Y)
            (AND (.EQ3 (CAR Y)
                        (CAR X))
                 (.EQ3 (CDR X)
                        (CDR Y]
           (T NIL)))
       ((OR (NUMBERP X)
            (STACKP X))
        (EQP X Y))
       ((STRINGP X)
        (STREQUAL X Y))
       (T NIL])
)

(RPAQQ TEST3
       ((TESTVALS (.SELECTQ 1 1 2)
               '(3 4 22)
               (.SELECTQ 1 3 3)
               '(3 3 22)
               (.SELECTQ 1 3 0)
               '(3 0 NIL)
               (.SELECTQ 2 2 2)
               '(3 0 NIL)
               (.SELECTQ 5 5 '(NIL NIL . 3))
               '(3 3 22)
               (.SELECTQ)
               '(3 NIL 22)
               (.SUBFNS)
               '(GOOD A 5 (1 2 3 4 5)
                      ((3)))
               (.MISC)
               '(1 NIL 3)
               (.FORTEST 3)
               '[(((3 3 3)
                   (3 3 3)
                   (3 3 3)) . 3)
                 (((3 3 3)
                   (3 3 3)) . 2)
                 (((3 3 3)) . 1]
               (.FORTEST 2)
               NIL)))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA NLAMA TESTIFSAME TESTVALS)

(ADDTOVAR NLAML NLAML !ADD1VAR .NLSETQ TESTPAIRS)

(ADDTOVAR LAMA LAMA !APPEND .LIST .SUM .TESTARG)
)
(PUTPROPS COMPTEST COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1988 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4163 9052 (MAKEFORM 4173 . 4647) (TESTER 4649 . 5171) (TEST1 5173 . 5469) (TRY 5471 . 
5724) (FAILTEST 5726 . 5801) (TESTVALS 5803 . 6509) (TESTIFSAME 6511 . 7073) (TESTPAIRS 7075 . 8489) (
EVALVARS 8491 . 8749) (TRYTEST 8751 . 9050)) (9298 12240 (IVAR 9308 . 9464) (PVAR 9466 . 9785) (
VARSWAP 9787 . 10109) (VARSWAP2 10111 . 10492) (VARSWAP3 10494 . 10835) (VARSWAP4 10837 . 11126) (
IVAR3 11128 . 11513) (IVARX 11515 . 12012) (FVAR 12014 . 12238)) (13301 13411 (.GETPROPLST 13311 . 
13409)) (13412 19707 (.LISTP 13422 . 13462) (.NLISTP 13464 . 13506) (.LITATOM 13508 . 13735) (.FLOATP 
13737 . 13962) (.FIXP 13964 . 14185) (.NUMBERP 14187 . 14413) (.SMALLP 14415 . 14639) (.STACKP 14641
 . 14866) (.ARRAYP 14868 . 15093) (.NLITATOM 15095 . 15328) (.NFLOATP 15330 . 15378) (.NNUMBERP 15380
 . 15430) (.NFIXP 15432 . 15476) (.NSMALLP 15478 . 15526) (.NARRAYP 15528 . 15576) (.NSTACKP 15578 . 
15626) (.NZEROP 15628 . 15674) (.ZEROP 15676 . 15899) (.STRINGP 15901 . 15945) (.NSTRINGP 15947 . 
15997) (.IGREATERP 15999 . 16051) (.NIGREATERP 16053 . 16111) (.ILESSP 16113 . 16159) (.NILESSP 16161
 . 16213) (.ATOM 16215 . 16253) (.NATOM 16255 . 16299) (.EQ 16301 . 16339) (.NEQ 16341 . 16381) (.NULL
 16383 . 16421) (.NNULL 16423 . 16502) (.IEQP 16504 . 16546) (.NIEQP 16548 . 16776) (.ORLISTP 16778 . 
17017) (.ANDLISTP 17019 . 17261) (.ORATOM 17263 . 17501) (.ANDATOM 17503 . 17744) (.ORZEROP 17746 . 
17984) (.ORNULL 17986 . 18223) (.ORARRAYP 18225 . 18466) (.ANDARRAYP 18468 . 18712) (.ANDNLISTP 18714
 . 18964) (.ANDNATOM 18966 . 19214) (.ORFLOATP 19216 . 19458) (.ANDFLOATP 19460 . 19705)) (24294 25310
 (.CONDRET 24304 . 24511) (.CONDRET2 24513 . 24722) (TESTRESUME 24724 . 25049) (GETLEAVES 25051 . 
25308)) (25590 28446 (.TESTARG 25600 . 25853) (.SET 25855 . 26007) (.EVALV1 26009 . 26232) (.EVALV2 
26234 . 26459) (.SUM 26461 . 26872) (.FIX 26874 . 27092) (.LIST 27094 . 27650) (.NLSETQ 27652 . 27885)
 (.EQUAL 27887 . 28039) (.SETX 28041 . 28444)) (29739 30661 (.ITIMES 29749 . 29795) (.IPLUS 29797 . 
29841) (.IQUOTIENT 29843 . 29895) (.IREMAINDER 29897 . 29951) (.ADD1 29953 . 29991) (.SUB1 29993 . 
30031) (.LLSH 30033 . 30075) (.LRSH 30077 . 30119) (.LSH 30121 . 30161) (.RSH 30163 . 30203) (.LOGAND 
30205 . 30251) (.LOGOR 30253 . 30297) (.LOGXOR 30299 . 30345) (.IDIFFERENCE 30347 . 30403) (.NT1 30405
 . 30476) (.NT2 30478 . 30547) (.NT3 30549 . 30659)) (31524 36078 (.NCONC 31534 . 31759) (..NCONC 
31761 . 32028) (.AND 32030 . 32309) (.FRPLNODE 32311 . 32544) (.OR 32546 . 32820) (.FRPLNODE2 32822 . 
33055) (..NCONC3 33057 . 33326) (.NCONC3 33328 . 33558) (SELECTTEST 33560 . 33879) (.MKLIST 33881 . 
34105) (.EQMEMB 34107 . 34333) (.NCONC1 34335 . 34561) (.GETPROPLIST 34563 . 34797) (.SETPROPLIST 
34799 . 35035) (.FGETD 35037 . 35077) (..FRPLNODE2 35079 . 35219) (!AND 35221 . 35652) (!OR 35654 . 
36076)) (38600 51527 (!ADD1VAR 38610 . 38834) (!APPEND 38836 . 39459) (APPEND2 39461 . 39795) (!ASSOC 
39797 . 40165) (!ATTACH 40167 . 40429) (!CHANGEPROP 40431 . 40691) (!COPY 40693 . 41044) (!DEFLIST 
41046 . 41431) (!DREMOVE 41433 . 42209) (!DREVERSE 42211 . 42261) (DREV 42263 . 42545) (!DSUBST 42547
 . 43109) (!EVERY 43111 . 43414) (!GETP 43416 . 43965) (!INTERSECTION 43967 . 44525) (!LAST 44527 . 
44780) (!LASTN 44782 . 45299) (!LDIFF 45301 . 45758) (!LENGTH 45760 . 45982) (!LISTGET 45984 . 46478) 
(!LSUBST 46480 . 47233) (!MAP 47235 . 47666) (!GET 47668 . 47847) (!GETLIS 47849 . 48173) (!MEMB 48175
 . 48489) (!NTH 48491 . 48846) (.COLLCT 48848 . 48973) (.ENDCOLLCT 48975 . 49104) (MYAPPEND1 49106 . 
49346) (MYAPPEND2 49348 . 49658) (COLLCT 49660 . 49906) (ENDCOLLCT 49908 . 50058) (.ATTACH 50060 . 
50181) (.APPEND0 50183 . 50300) (.APPEND1 50302 . 50527) (.APPEND2 50529 . 50756) (.APPEND3 50758 . 
50987) (.APPEND4 50989 . 51220) (.MAPCGETP 51222 . 51525)) (57139 59034 (.MAP 57149 . 57496) (.MAPC 
57498 . 58701) (.MAPCEFF 58703 . 59032)) (59283 60308 (.FPLUS 59293 . 59546) (.FTIMES 59548 . 59804) (
.FDIFFERENCE 59806 . 60072) (.FQUOTIENT 60074 . 60306)) (60538 62084 (NONLOCALGO 60548 . 61488) (
CNTDWN 61490 . 61828) (JUMPAROUND 61830 . 62082)) (62332 63275 (FN2 62342 . 62566) (FN3 62568 . 62795)
 (FN1 62797 . 63019) (.IVAR 63021 . 63273)) (63566 64949 (.GETP 63576 . 63618) (.GETPROP 63620 . 63668
) (.RPLACA 63670 . 63897) (.RPLACD 63899 . 64126) (.FRPLACA 64128 . 64357) (.GET 64359 . 64490) (
.FRPLACD 64492 . 64721) (.ASSOC 64723 . 64767) (.LENGTH 64769 . 64811) (.LAST 64813 . 64851) (.GETHASH
 64853 . 64901) (.FMEMB 64903 . 64947)) (66825 69610 (.CONS 66835 . 66877) (LIST0 66879 . 67098) (
LIST1 67100 . 67138) (LIST2 67140 . 67182) (LIST3 67184 . 67230) (LIST4 67232 . 67459) (LIST5 67461 . 
67690) (LIST6 67692 . 67923) (LIST7 67925 . 68158) (LIST8 68160 . 68395) (LIST9 68397 . 68634) (LIST10
 68636 . 68875) (LIST11 68877 . 69118) (LIST12 69120 . 69362) (LIST13 69364 . 69608)) (70456 70937 (
.CAR 70466 . 70502) (.CDR 70504 . 70540) (.CAAR 70542 . 70580) (.CDAR 70582 . 70620) (.CADR 70622 . 
70660) (.CDDR 70662 . 70700) (.CAAAAR 70702 . 70935)) (71304 71688 (.LAM0 71314 . 71354) (..LAM0 71356
 . 71409) (.LAM1 71411 . 71451) (..LAM1 71453 . 71532) (.NLAML 71534 . 71618) (LAM1LOC 71620 . 71686))
 (72373 78386 (.PROGS 72383 . 75049) (.SPEC 75051 . 76590) (.COND 76592 . 77472) (.DELBIND 77474 . 
78384)) (78774 79492 (T1 78784 . 78813) (T0 78815 . 78844) (TT 78846 . 78875) (TNIL 78877 . 78910) (
T-1 78912 . 78943) (T2 78945 . 78974) (T12 78976 . 79007) (T377 79009 . 79042) (T400Q 79044 . 79167) (
T-400 79169 . 79204) (TSTR 79206 . 79330) (.NILARGS 79332 . 79490)) (80021 82831 (.BIND0 80031 . 80185
) (.BIND1 80187 . 80578) (.BIND2 80580 . 80972) (.BIND3 80974 . 81411) (.BIND4 81413 . 81850) (
.BINDASSOC 81852 . 82124) (.BIND5 82126 . 82530) (.BINDPOP 82532 . 82829)) (84968 85553 (LAM0 84978 . 
85007) (LAM1 85009 . 85143) (LAMA 85145 . 85277) (NLAML 85279 . 85415) (NLAMA 85417 . 85551)) (85554 
90847 (.SELECTQ 85564 . 86277) (.SUBFNS 86279 . 86775) (.MISC 86777 . 87069) (.FORTEST 87071 . 87330) 
(.BIGCOND 87332 . 87603) (.RECORDTEST 87605 . 88538) (.PROGRETURN 88540 . 88835) (.ALWAYSFALSE 88837
 . 89109) (.ALWAYSTRUE 89111 . 89333) (.EQ1 89335 . 89802) (.EQ2 89804 . 90340) (.EQ3 90342 . 90845)))
))
STOP
\ No newline at end of file
diff --git a/internal/library/CONDITIONGRAPH b/internal/library/CONDITIONGRAPH
new file mode 100644
index 00000000..48353744
--- /dev/null
+++ b/internal/library/CONDITIONGRAPH
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "IL")
(FILECREATED "14-Jun-90 21:03:42" 
|{DSK}<usr>local>lde>lispcore>internal>library>CONDITIONGRAPH.;2| 5185   

      |changes| |to:|  (VARS CONDITIONGRAPHCOMS)

      |previous| |date:| " 9-Dec-87 16:48:03" 
|{DSK}<usr>local>lde>lispcore>internal>library>CONDITIONGRAPH.;1|)


; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT CONDITIONGRAPHCOMS)

(RPAQQ CONDITIONGRAPHCOMS ((DECLARE\: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY (XCL:FILE-ENVIRONMENTS
                                                                               :CONDITIONGRAPH))
                               (VARIABLES *CONDITION-GRAPH-WINDOW* *CONDITION-GRAPH-SEXPR*)
                               (FUNCTIONS EDIT-CONDITIONS GRAPH-CONDITIONS CONDITION-SUBGRAPH 
                                      CONDITION-SUBGRAPH-RECURSION RECOMPUTE-CONDITION-GRAPH-SEXPR 
                                      COUNT-CONDITION-TYPES COUNT-CONDITION-TYPES-RECURSION)
                               (PROP CONDITIONGRAPH)))
(DECLARE\: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY 

(XCL:DEFINE-FILE-ENVIRONMENT :CONDITIONGRAPH :READTABLE "XCL"
   :PACKAGE "IL"
   :COMPILER :COMPILE-FILE)
)

(CL:DEFVAR *CONDITION-GRAPH-WINDOW* NIL
   "Window in which to display the condition hierarchy graph.")

(CL:DEFVAR *CONDITION-GRAPH-SEXPR* NIL
   "Tree structure representing last calculated condition type graph.")

(CL:DEFUN EDIT-CONDITIONS (ROOT)
   (CL:LABELS ((EDIT-CONDITIONS-RECURSION (GRAPH)
                      (CL:UNLESS (NULL GRAPH)
                          (ED (CL:FIRST GRAPH)
                              :STRUCTURES)
                          (CL:MAPC #'EDIT-CONDITIONS-RECURSION (CL:REST GRAPH)))))
          (EDIT-CONDITIONS-RECURSION (CONDITION-SUBGRAPH ROOT NIL))))

(CL:DEFUN GRAPH-CONDITIONS (&OPTIONAL (ROOT 'CONDITION)
                                      (RECOMPUTE (NULL *CONDITION-GRAPH-SEXPR*))
                                      W)
   (LET ((NEWW (SHOWGRAPH (LAYOUTSEXPR (CONDITION-SUBGRAPH ROOT RECOMPUTE)
                                 '(HORIZONTAL))
                      (OR W *CONDITION-GRAPH-WINDOW* (CL:FORMAT NIL "Condition type graph from: ~S" 
                                                            ROOT))
                      NIL NIL T)))
        (WINDOWPROP NEWW 'TITLE (CL:FORMAT NIL "Condition type graph from: ~S" ROOT))
        (OR W *CONDITION-GRAPH-WINDOW* (CL:SETF *CONDITION-GRAPH-WINDOW* NEWW))))

(CL:DEFUN CONDITION-SUBGRAPH (ROOT RECOMPUTE &AUX (ONCE NIL)
                                       RESULT)
   (CL:UNLESS (CL:SUBTYPEP ROOT 'CONDITION)
          (CL:ERROR "~S is not a condition type."))
   (CL:LOOP (CL:WHEN RECOMPUTE (RECOMPUTE-CONDITION-GRAPH-SEXPR))
          (CL:SETF RESULT (CONDITION-SUBGRAPH-RECURSION ROOT *CONDITION-GRAPH-SEXPR*))
          (CL:WHEN (OR ONCE RESULT)
                 (CL:RETURN-FROM CONDITION-SUBGRAPH RESULT))
          (CL:FORMAT *ERROR-OUTPUT* "Couldn't find ~S in current graph.")
          (CL:SETQ ONCE T RECOMPUTE T)))

(CL:DEFUN CONDITION-SUBGRAPH-RECURSION (TARGET TREE)
   (COND
      ((NULL TREE)
       NIL)
      ((EQ TARGET (CL:FIRST TREE))
       TREE)
      (T (CL:DOLIST (SUBTREE (CL:REST TREE))
             (LET ((FOUND? (CONDITION-SUBGRAPH-RECURSION TARGET SUBTREE)))
                  (CL:WHEN FOUND? (RETURN FOUND?)))))))

(CL:DEFUN RECOMPUTE-CONDITION-GRAPH-SEXPR ()
   (LET ((CGHASH (CL:MAKE-HASH-TABLE)))
        (CL:FORMAT *ERROR-OUTPUT* " Computing condition hierarchy graph.")
        (MAPCAR (DATATYPES)
               #'(CL:LAMBDA (SYMBOL)
                        (BLOCK)
                        (CL:WHEN (AND (NOT (CL:GETHASH SYMBOL CGHASH))
                                      (CL:SUBTYPEP SYMBOL 'CONDITION))
                            (CL:DO ((TYPE SYMBOL (CONDITION-PARENT TYPE))
                                    (CHAIN NIL))
                                   ((COND
                                       ((NULL TYPE)
                                        (CL:SETF *CONDITION-GRAPH-SEXPR* CHAIN))
                                       ((CL:GETHASH TYPE CGHASH)
                                        (NCONC (CL:GETHASH TYPE CGHASH)
                                               (LIST CHAIN)))
                                       (T NIL)))
                                (CL:PRINC ".")
                                (CL:SETF (CL:GETHASH TYPE CGHASH)
                                       (CL:SETF CHAIN (CL:IF (NULL CHAIN)
                                                          (LIST TYPE)
                                                          (LIST TYPE CHAIN))))))))))

(CL:DEFUN COUNT-CONDITION-TYPES ()
   (COUNT-CONDITION-TYPES-RECURSION (CONDITION-SUBGRAPH 'CONDITION NIL)))

(CL:DEFUN COUNT-CONDITION-TYPES-RECURSION (TREE)
   (COND
      ((NULL TREE)
       0)
      ((CL:SYMBOLP TREE)
       1)
      (T (FOR SUBTREE IN TREE SUM (COUNT-CONDITION-TYPES-RECURSION SUBTREE)))))
(PUTPROPS CONDITIONGRAPH COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/internal/library/DICOLOR b/internal/library/DICOLOR
new file mode 100644
index 00000000..1a6003bd
--- /dev/null
+++ b/internal/library/DICOLOR
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 13:49:37" {DSK}<usr>local>lde>lispcore>internal>library>DICOLOR.;2 20737  

      changes to%:  (VARS DICOLORCOMS)

      previous date%: "15-Aug-85 19:44:58" {DSK}<usr>local>lde>lispcore>internal>library>DICOLOR.;1
)


(* ; "
Copyright (c) 1985, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT DICOLORCOMS)

(RPAQQ DICOLORCOMS
       ((FNS CNSMENUINIT CNSTOCSL CNSTORGB CSLTOCNS DICOLOR.FROM.USER GETCNS HLSTOCSL CSLTOHLS 
             RGBTOCNS)
        (VARS DICOLOR.hueMapping DICOLOR.lightnessMapping DICOLOR.saturationMapping NEWCOLORITEM)
        (INITVARS (COLORNAMEMENU))
        (FNS DICOLOR.hueN DICOLOR.hueNvalue DICOLOR.hueNname DICOLOR.lightnessN 
             DICOLOR.lightnessNvalue DICOLOR.lightnessNname DICOLOR.saturationN 
             DICOLOR.saturationNvalue DICOLOR.saturationNname)
        (DECLARE%: DONTCOPY (*)
               (RECORDS hueRecord lightnessRecord saturationRecord)
               (CONSTANTS * DICOLOR.hueConstants)
               (CONSTANTS * DICOLOR.saturationConstants)
               (CONSTANTS * DICOLOR.lightnessConstants))))
(DEFINEQ

(CNSMENUINIT
  [LAMBDA NIL                                            (* gbn " 9-Aug-85 03:11")
    [SETQ CNSHUEMENU (create MENU
                            ITEMS _ (for I in DICOLOR.hueMapping collect (CAR I]
    [SETQ CNSSATURATIONMENU (create MENU
                                   ITEMS _ (for I in DICOLOR.saturationMapping
                                              collect (CAR I]
    (SETQ CNSLIGHTNESSMENU (create MENU
                                  ITEMS _ (for I in DICOLOR.lightnessMapping
                                             collect (CAR I])

(CNSTOCSL
  [LAMBDA (hue saturation lightness)                     (* hdj "12-Apr-85 19:01")
    (PROG ((hueAtom (MKATOM hue))
           (saturationAtom (MKATOM saturation))
           (lightnessAtom (MKATOM lightness))
           c s l)
          (if [NOT (SETQ c (fetch (hueRecord ordering) of (ASSOC hueAtom 
                                                                             DICOLOR.hueMapping]
              then (SETQ c DICOLOR.achromatic))
          (if (EQ c DICOLOR.achromatic)
              then (SETQ s DICOLOR.noSaturation)
            else (if [NOT (SETQ s (fetch (saturationRecord ordering)
                                             of (ASSOC saturationAtom DICOLOR.saturationMapping]
                         then (SETQ s DICOLOR.vivid)))
          (SELECTQ hueAtom
              (Black (SETQ l DICOLOR.black))
              (White (SETQ l DICOLOR.white))
              (if [NOT (SETQ l (fetch (lightnessRecord ordering) of (ASSOC lightnessAtom
                                                                                       
                                                                             DICOLOR.lightnessMapping
                                                                                       ]
                  then (SETQ l DICOLOR.medium)))
          (RETURN (LIST c s l])

(CNSTORGB
  [LAMBDA (saturation lightness hue)                     (* hdj "15-Jul-85 12:33")
    (LET ((CSL (CNSTOCSL hue saturation lightness)))
         (HLSTORGB (APPLY (FUNCTION CSLTOHLS)
                          CSL])

(CSLTOCNS
  [LAMBDA (c s l)                                        (* hdj "15-Jul-85 12:37")
    (PROG (hue saturation lightness)
          [if (EQ c DICOLOR.achromatic)
              then (SETQ saturation "")
                    [SELECTC l
                        (DICOLOR.black (SETQ hue "Black")
                                       (SETQ lightness ""))
                        (DICOLOR.white (SETQ hue "White")
                                       (SETQ lightness ""))
                        (PROGN (SETQ hue "Gray")
                               (SETQ lightness (MKSTRING (fetch (lightnessRecord name)
                                                            of (DICOLOR.lightnessN l]
            else (SETQ hue (fetch (hueRecord name) of (DICOLOR.hueN c)))
                  (SETQ saturation (fetch (saturationRecord name) of (DICOLOR.saturationN
                                                                              s)))
                  (SETQ lightness (fetch (lightnessRecord name) of (DICOLOR.lightnessN
                                                                            l]
          (RETURN (LIST saturation lightness hue])

(DICOLOR.FROM.USER
  [LAMBDA (NAMES?)                                       (* gbn " 9-Aug-85 04:51")

         (* * returns an RGB triple. If NAMES? prompts the user first with the global 
       color name menu. She can then choose NEWCOLOR which can be specified as RGB or 
       CNS)

    (PROG (NAME RGB)
          (if NAMES?
              then                                       (* first try to get a color name)
                    [SETQ NAME (MENU (OR COLORNAMEMENU (SETQ COLORNAMEMENU
                                                        (CREATE MENU
                                                               ITEMS _
                                                               (CONS NEWCOLORITEM
                                                                     (FOR ENTRY IN COLORNAMES
                                                                        COLLECT (CAR ENTRY]
                    (if (NOT NAME)
                        then                             (* the user clicked outside the menu)
                              (RETURN))
                    [SETQ RGB (SELECTQ NAME
                                  (RGB (READCOLOR1 "specify new color"))
                                  (CNS (APPLY (FUNCTION CNSTORGB)
                                              (GETCNS)))
                                  (RETURN (CDR (ASSOC NAME COLORNAMES]
                    (if (NOT (SETQ NAME (TTYIN "New color name? ")))
                        then                             (* user must have decided that she 
                                                           didn't want to keep
                                                           (name) the color)
                              (RETURN))
                    (push COLORNAMES (CONS (CAR NAME)
                                               RGB))
                    (SETQ COLORNAMEMENU NIL)                 (* invalidate the menu)
                    (RETURN RGB])

(GETCNS
  [LAMBDA NIL                                            (* gbn " 9-Aug-85 03:13")
    (LIST (MENU CNSLIGHTNESSMENU)
          (MENU CNSSATURATIONMENU)
          (MENU CNSHUEMENU])

(HLSTOCSL
  [LAMBDA (hue lightness saturation)                     (* hdj "15-Jul-85 12:14")
    (LET
     ((ISLHue (FQUOTIENT (MOD (PLUS hue 240)
                              360)
                     360)))
     (PROG (c s l)
           (for old s from DICOLOR.noSaturation to DICOLOR.vivid
              do (if (EQ s DICOLOR.vivid)
                         then (RETURN))
                    (if (LEQ saturation (PLUS (DICOLOR.saturationNvalue s)
                                                  (QUOTIENT (DIFFERENCE (DICOLOR.saturationNvalue
                                                                         (ADD1 s))
                                                                   (DICOLOR.saturationNvalue
                                                                    s))
                                                         2)))
                        then (RETURN)))
           [if (EQ s DICOLOR.noSaturation)
               then (SETQ c DICOLOR.achromatic)
                     (for old l from DICOLOR.black to DICOLOR.white
                        do (if (EQ l DICOLOR.white)
                                   then (RETURN))
                              (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l)
                                                           (QUOTIENT (DIFFERENCE (
                                                                            DICOLOR.lightnessNvalue
                                                                                  (ADD1 l))
                                                                            (
                                                                           DICOLOR.lightnessNvalue
                                                                             l))
                                                                  2)))
                                  then (RETURN)))
             else (for old c from DICOLOR.red to DICOLOR.purplishRed
                         do                              (* (HELP c))
                               (if (EQ c DICOLOR.purplishRed)
                                   then (if (GREATERP ISLHue
                                                           (PLUS (DICOLOR.hueNvalue c)
                                                                 (QUOTIENT (DIFFERENCE 1 (
                                                                                  DICOLOR.hueNvalue
                                                                                          c))
                                                                        2)))
                                                then (SETQ c DICOLOR.red))
                                         (RETURN))
                               (if (LEQ ISLHue (PLUS (DICOLOR.hueNvalue c)
                                                         (QUOTIENT (DIFFERENCE (DICOLOR.hueNvalue
                                                                                (ADD1 c))
                                                                          (DICOLOR.hueNvalue
                                                                           c))
                                                                2)))
                                   then (RETURN)))
                   (for old l from DICOLOR.veryDark to DICOLOR.veryLight
                      do (if (EQ l DICOLOR.veryLight)
                                 then (RETURN))
                            (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l)
                                                         (QUOTIENT (DIFFERENCE (
                                                                            DICOLOR.lightnessNvalue
                                                                                (ADD1 l))
                                                                          (DICOLOR.lightnessNvalue
                                                                           l))
                                                                2)))
                                then (RETURN]
           (RETURN (LIST c s l])

(CSLTOHLS
  [LAMBDA (c s l)                                        (* hdj "15-Jul-85 12:23")
    (PROG (hue saturation lightness)
          (if (EQ c DICOLOR.achromatic)
              then (SETQ hue 0.0)
                    (SETQ saturation 0.0)
                    (SETQ lightness (DICOLOR.lightnessNvalue l))
            else (SETQ hue (DICOLOR.hueNvalue c))
                  (SETQ saturation (DICOLOR.saturationNvalue s))
                  (SETQ lightness (DICOLOR.lightnessNvalue l)))
          (RETURN (LIST (MOD (FPLUS 120 (FTIMES hue 360))
                             360)
                        lightness saturation])

(RGBTOCNS
  [LAMBDA (Red Green Blue)                               (* hdj "15-Jul-85 12:36")
    (APPLY (FUNCTION CSLTOCNS)
           (APPLY (FUNCTION HLSTOCSL)
                  (RGBTOHLS Red Green Blue])
)

(RPAQQ DICOLOR.hueMapping
       ((Achromatic 0.0 -1)
        (Red 0.0 0)
        (OrangishRed 0.01 1)
        (RedOrange 0.02 2)
        (ReddishOrange 0.03 3)
        (Orange 0.04 4)
        (YellowishOrange 0.07 5)
        (OrangeYellow 0.1 6)
        (OrangishYellow 0.13 7)
        (Yellow 0.1673 8)
        (GreenishYellow 0.2073 9)
        (YellowGreen 0.2473 10)
        (YellowishGreen 0.2873 11)
        (Green 0.3333 12)
        (BluishGreen 0.4133 13)
        (GreenBlue 0.4933 14)
        (GreenishBlue 0.5733 15)
        (Blue 0.6666 16)
        (PurplishBlue 0.6816 17)
        (BluePurple 0.6966 18)
        (BluishPurple 0.7116 19)
        (Purple 0.73 20)
        (ReddishPurple 0.8 21)
        (PurpleRed 0.87 22)
        (PurplishRed 0.94 23)
        (BrownishRed 0.01 24)
        (RedBrown 0.02 25)
        (ReddishBrown 0.03 26)
        (Brown 0.04 27)
        (YellowishBrown 0.07 28)
        (BrownYellow 0.1 29)
        (BrownishYellow 0.13 30)))

(RPAQQ DICOLOR.lightnessMapping ((Black 0.0 0)
                                     (VeryDark 0.1666 1)
                                     (Dark 0.3333 2)
                                     (Medium 0.5 3)
                                     (Light 0.6666 4)
                                     (VeryLight 0.8333 5)
                                     (White 1.0 6)))

(RPAQQ DICOLOR.saturationMapping ((NoSaturation 0.0 0)
                                      (Grayish 0.25 1)
                                      (Moderate 0.5 2)
                                      (Strong 0.75 3)
                                      (Vivid 1.0 4)))

(RPAQQ NEWCOLORITEM (New% Color 'CNS "Allows specification of a new color"
                               (SUBITEMS (RGB 'RGB 
                                              "Specify a new color using Red, Green, Blue sliders")
                                      (CNS 'CNS "Specify a new color using English"))))

(RPAQ? COLORNAMEMENU )
(DEFINEQ

(DICOLOR.hueN
  [LAMBDA (N)                                            (* hdj "17-Apr-85 13:38")
    (DECLARE (GLOBALVARS DICOLOR.hueMapping))
    (for ELT in DICOLOR.hueMapping suchthat (EQ (fetch (hueRecord ordering)
                                                               of ELT)
                                                            N])

(DICOLOR.hueNvalue
  [LAMBDA (N)                                            (* hdj "18-Apr-85 09:58")
    (fetch (hueRecord value) of (DICOLOR.hueN N])

(DICOLOR.hueNname
  [LAMBDA (N)                                            (* hdj "18-Apr-85 10:07")
    (fetch (hueRecord name) of (DICOLOR.hueN N])

(DICOLOR.lightnessN
  [LAMBDA (N)                                            (* hdj "17-Apr-85 13:40")
    (DECLARE (GLOBALVARS DICOLOR.lightnessMapping))
    (for ELT in DICOLOR.lightnessMapping suchthat (EQ (fetch (lightnessRecord 
                                                                                    ordering)
                                                                     of ELT)
                                                                  N])

(DICOLOR.lightnessNvalue
  [LAMBDA (N)                                            (* hdj "17-Apr-85 13:36")
    (fetch (lightnessRecord value) of (DICOLOR.lightnessN N])

(DICOLOR.lightnessNname
  [LAMBDA (N)                                            (* hdj "17-Apr-85 14:02")
    (fetch (lightnessRecord name) of (DICOLOR.lightnessN N])

(DICOLOR.saturationN
  [LAMBDA (N)                                            (* hdj "17-Apr-85 13:39")
    (DECLARE (GLOBALVARS DICOLOR.saturationMapping))
    (for ELT in DICOLOR.saturationMapping suchthat (EQ (fetch (saturationRecord
                                                                               ordering) of
                                                                                         ELT)
                                                                   N])

(DICOLOR.saturationNvalue
  [LAMBDA (N)                                            (* hdj "17-Apr-85 13:36")
    (fetch (saturationRecord value) of (DICOLOR.saturationN N])

(DICOLOR.saturationNname
  [LAMBDA (N)                                            (* hdj "17-Apr-85 14:02")
    (fetch (saturationRecord name) of (DICOLOR.saturationN N])
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD hueRecord (name value ordering))

(RECORD lightnessRecord (name value ordering))

(RECORD saturationRecord (name value ordering))
)


(RPAQQ DICOLOR.hueConstants
       (DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple 
              DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow 
              DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow 
              DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow 
              DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red 
              DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange 
              DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown 
              DICOLOR.yellowishGreen DICOLOR.yellowishOrange))
(DECLARE%: EVAL@COMPILE 

(RPAQQ DICOLOR.achromatic -1)

(RPAQQ DICOLOR.blue 16)

(RPAQQ DICOLOR.bluePurple 18)

(RPAQQ DICOLOR.bluishGreen 13)

(RPAQQ DICOLOR.bluishPurple 19)

(RPAQQ DICOLOR.brown 27)

(RPAQQ DICOLOR.brownYellow 29)

(RPAQQ DICOLOR.brownishRed 24)

(RPAQQ DICOLOR.brownishYellow 30)

(RPAQQ DICOLOR.green 12)

(RPAQQ DICOLOR.greenBlue 14)

(RPAQQ DICOLOR.greenishBlue 15)

(RPAQQ DICOLOR.greenishYellow 9)

(RPAQQ DICOLOR.orange 4)

(RPAQQ DICOLOR.orangeYellow 6)

(RPAQQ DICOLOR.orangishRed 1)

(RPAQQ DICOLOR.orangishYellow 7)

(RPAQQ DICOLOR.purple 20)

(RPAQQ DICOLOR.purpleRed 22)

(RPAQQ DICOLOR.purplishBlue 17)

(RPAQQ DICOLOR.purplishRed 23)

(RPAQQ DICOLOR.red 0)

(RPAQQ DICOLOR.redBrown 25)

(RPAQQ DICOLOR.redOrange 2)

(RPAQQ DICOLOR.reddishBrown 26)

(RPAQQ DICOLOR.reddishOrange 3)

(RPAQQ DICOLOR.reddishPurple 21)

(RPAQQ DICOLOR.yellow 8)

(RPAQQ DICOLOR.yellowGreen 10)

(RPAQQ DICOLOR.yellowishBrown 28)

(RPAQQ DICOLOR.yellowishGreen 11)

(RPAQQ DICOLOR.yellowishOrange 5)


(CONSTANTS DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen 
       DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed 
       DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue 
       DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed 
       DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue 
       DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown 
       DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen 
       DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange)
)


(RPAQQ DICOLOR.saturationConstants (DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate 
                                              DICOLOR.strong DICOLOR.vivid))
(DECLARE%: EVAL@COMPILE 

(RPAQQ DICOLOR.noSaturation 0)

(RPAQQ DICOLOR.grayish 1)

(RPAQQ DICOLOR.moderate 2)

(RPAQQ DICOLOR.strong 3)

(RPAQQ DICOLOR.vivid 4)


(CONSTANTS DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid)
)


(RPAQQ DICOLOR.lightnessConstants (DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium 
                                             DICOLOR.light DICOLOR.veryLight DICOLOR.white))
(DECLARE%: EVAL@COMPILE 

(RPAQQ DICOLOR.black 0)

(RPAQQ DICOLOR.veryDark 1)

(RPAQQ DICOLOR.dark 2)

(RPAQQ DICOLOR.medium 3)

(RPAQQ DICOLOR.light 4)

(RPAQQ DICOLOR.veryLight 5)

(RPAQQ DICOLOR.white 6)


(CONSTANTS DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight
       DICOLOR.white)
)
)
(PUTPROPS DICOLOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1197 12278 (CNSMENUINIT 1207 . 1838) (CNSTOCSL 1840 . 3245) (CNSTORGB 3247 . 3486) (
CSLTOCNS 3488 . 4721) (DICOLOR.FROM.USER 4723 . 6789) (GETCNS 6791 . 6991) (HLSTOCSL 6993 . 11386) (
CSLTOHLS 11388 . 12056) (RGBTOCNS 12058 . 12276)) (14261 16839 (DICOLOR.hueN 14271 . 14660) (
DICOLOR.hueNvalue 14662 . 14837) (DICOLOR.hueNname 14839 . 15012) (DICOLOR.lightnessN 15014 . 15524) (
DICOLOR.lightnessNvalue 15526 . 15719) (DICOLOR.lightnessNname 15721 . 15912) (DICOLOR.saturationN 
15914 . 16443) (DICOLOR.saturationNvalue 16445 . 16641) (DICOLOR.saturationNname 16643 . 16837)))))
STOP
\ No newline at end of file
diff --git a/internal/library/DO-TEST b/internal/library/DO-TEST
new file mode 100644
index 00000000..7245314f
Binary files /dev/null and b/internal/library/DO-TEST differ
diff --git a/internal/library/DO-TEST.TEDIT b/internal/library/DO-TEST.TEDIT
new file mode 100644
index 00000000..f53f7e2b
--- /dev/null
+++ b/internal/library/DO-TEST.TEDIT
@@ -0,0 +1,165 @@
+Writing Software Tests
What File to Load; Conventions
Load the file Internal>Library>Do-Test.DFasl.
All the symbols mentioned in this document are in both the IL: and XCL-TEST: packages, unless otherwise stated.
You should also read the How-To sheet on writing AR Test Cases.
Main Testing Entry Points
(DEFTEST name&options forms)	[Definer]
This is the definer for tests, allowing them to be saved on file-managed files.  The test succeeds if the final form returns a non-NIL result.  If name&options isn't a list, then it's just the name which can be a symbol or string; symbols are preferred for DEFTEST tests.  If you specify options, the CAR of name&options is the name.  If you specify :COMPILED in name&options, the test will run only when it has been compiled.  Since this test is stored as structure rather than as plain text, any symbols will be package-qualified appropriately. If a test fails or an error occurs during evaluation, a message is printed to *ERROR-OUTPUT*.
Unless you have DFNFLG set to PROP, the act of defining a test also causes it to be run (so you'll see if your test fails right away).
Examples:
	(DEFTEST AR1000	; For AR test cases, the test name should be ARar#.
	   (= 3 (+ 1 2)))	; Real simple test of +
	(DEFTEST (+-OPT :COMPILED)	; A test of the compiler, only makes sense to run compiled.
	   (= 3 (+ 1 1 1)))		; Checking that +'s optimizer does the right thing.
	(DEFTEST (MS-TEST :INTERPRETED)	; A test of Masterscope, only makes sense interpreted.
	   (TEST-DEFUN FN (X) (FOO X))
	   (\. IS FOO CALLED BY FN))
(DEFTESTGROUP name&options forms)	[Definer]
This is the definer for groups of tests, allowing them to be saved on file-managed files.  For associating a group of tests.  For instance, a group of tests may all require the same setup and cleanup. If there are any options (see below) then the CAR of name&options is the name and the CDR is a keyword/value list. All forms must be DEFTEST or DO-TEST forms.
Unless you have DFNFLG set to PROP, the act of defining a test group also causes it to be run (so you'll see if your tests fail right away).
:before	 allows for a setup form for a group of tests.
:after	 allows a form to be run after the tests without affecting results.
The normal form of a DEFTESTGROUP using all its features is:
	(DEFTESTGROUP
		(UNWIND-OPCODE-TESTS
		  :BEFORE (progn (before-form-1) (before-form-2)...)
		  :AFTER  (progn (after-form-1) (after-form-2))
		)
		(DEFTEST "first test" ....)
		(DEFTEST "second test" ....)
	)
Functions You'll Find Useful When Building Tests
(EXPECT-ERRORS (error-types) forms)	[Macro]
Error-types is a list of errors that may occur while executing the forms. If one of the listed errors occurs, EXPECT-ERRORS returns (values t error-that-occurred), otherwise NIL.  If all you want to do is make sure that an error is signalled somewhere in the test, you can specify an error-types of T. Normal use of this form is:
	(DEFTEST ERROR-CHECK
		(EXPECT-ERRORS (T)
			(THIS-FORM 'SHOULD 'ERROR)))
	(DEFTEST (+-DETECTS-NILS :INTERPRETED)
		(EXPECT-ERRORS (XCL:TYPE-MISMATCH)
			(+ 3 NIL)))
(TEST-SETQ Variable Value)
(TEST-DEFUN name (arglist) forms)
(TEST-DEFMACRO name (arglist) forms)	[Macros]
These work like SETQ, DEFUN, and DEFMACRO, except that if they are executed within a DEFTEST or DEFTESTGROUP, their effects are manually undone (old values are saved and then restored) upon leaving the test. Use these in :BEFORE forms that a whole group of DEFTESTs want to see. DON'T use TEST-SETQ on locally-bound variables or in loops.
Commands and Functions for Running Tests
run Test-name	[EXEC Command]
Once Test-name has been defined using DEFTEST or DEFTESTGROUP, you can run the test with the run command.
(DO-TEST-FILE filename)
Reads and executes a file of tests.  All forms in the file are read before any are executed. The file should be clear text (clearput in TEdit) and terminate with a STOP.  The format for test names is 
Chap#[-sec#[-subsec#]]-comment.TEST
(DO-ALL-TESTS &key (results *test-batch-results*)
				     (patterns *test-file-pattern*)
				     (sysout-type nil)
				     (resume nil))
Calls DO-TEST-FILE on each file that matches patterns, which is a list of directory patterns, and prints the results to a new version of a file named results. If results is T, results are printed to the window where DO-ALL-TESTS is running. The header of the results file is a message of the date and time the tests are being run and the MAKESYSDATE of the sysout; if sysout-type is supplied, a line for it goes out too. If resume is non-NIL, DO-ALL-TESTS attempts to resume an interrupted test sequence, appending the results onto the latest version of results.
*TEST-MODE*	[Variable]
Default is :batch, which means to report test failures and errors on *ERROR-OUTPUT* (which is usually a file), and continue.  Other values possible are: :interactive which means to print a message before running each test, print another message for test failures, and produce a break window on errors. :batch-verbose which means to generate all the messages of :interactive and do not break on errors.
*TEST-BATCH-RESULTS*	[Variable]
Defaults to "{eris}<lispcore>cml>test>test-results"
*TEST-FILE-PATTERN*	[Variable]
Defaults to ("{eris}<lispcore>cml>test>*.test;" "{eris}<lispcore>cml>test>*.x") which runs all the internal tests.
*TEST-COMPILE*	[Variable]
If this switch is non-nil, DO-TEST compiles its forms before testing them. DO-ALL-TESTS will print a message in its header if this switch is on.
*ALL-FILES-REMAINING*	[Variable]
While DO-ALL-TESTS is running, this variable contains a list of all the files remaining to be processed; files are removed from it AFTER they are read and executed. To restart a test run that somehow crashes the test driver, first clean up whatever blew up the run (if necessary, dump *ALL-FILES-REMAINING* to a file and get a new sysout), then do
(DO-ALL-TESTS :RESUME T [:RESULTS "wherever"]).
Internal Functions
(DO-TEST name&options forms)	[Macro]
This is the obsolete, plain-test-file testing macro; it is still around so that old tests work (and because DEFTEST uses it).  A test succeeds if the final form returns a non-nil result.  If name&options isn't a list, then it's just the name which can be an atom or string; strings are preferred.  If you specify options, the CAR of name&options is the name.  If you specify :COMPILED in name&options, the test will run only when it has been compiled.  Forms are presumed to be read with the Common Lisp reader in package XCL-TEST, which uses LISP and XCL. If a test fails or an error occurs during evaluation, a message is printed to *ERROR-OUTPUT*.
(DO-TEST-GROUP name&options forms)	[Macro]
This is the obsolete, plain-test-file testing macro; it is still around so that old tests work (and because DEFTESTGROUP uses it).  For associating a group of tests.  For instance, a group of tests may all require the same setup and cleanup. If there are any options (see below) then the CAR of name&options is the name and the CDR  is a keyword/value list. All forms must be DO-TEST forms.
:before	 allows for a setup form for a group of tests.
:after	 allows a form to be run after the tests without affecting results.

The normal form of a DO-TEST-GROUP using all its features is:
(DO-TEST-GROUP
	("a test group"
	:BEFORE (progn (before-form-1) (before-form-2)...)
	:AFTER (progn (after-form-1) (after-form-2))
	)
	(DO-TEST "first test" ....)
	(DO-TEST "second test" ....)
)
(CL-READFILE filename)
Reads all forms in filename and returns a list of them. This function is used by DO-TEST-FILE to read test files; test writers who want to see if their files are syntactically valid should first see if CL-READFILE will read them, then see if DO-TEST-FILE will execute them.
(MUNG-TEST-FILES filepattern &key (compiler 'compile-file)
						  (startinglist NIL))
Compiles test files so they can be run by just loading them.  Compiles all files matching filepattern (which is fed to directory) using compiler and writes them out to the directory they came from with an extension appropriate to compiler.  If you want to explicitly specify the list of files to compile, hand a list of pathnames to startinglist.  Prints an error message for files that fail to compile.  You have to use this function (instead of just compiling the test files) because it prefaces the test files with (in-package "XCL-TEST") and (setq *test-file-name* "NAME-OF-FILE") so the compiler will read them properly and the files will know their names for error reporting purposes.  NOTE: tests that fail should not be compiled; the resulting compiled code may not be a valid test.
.=�$Z�=�$Z�:�$�:�$�:�$�7$.
+MODERNMODERNMODERN
+MODERN
+TERMINAL
+?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8))
+GACHA
+
+TIMESROMAN
+
+TIMESROMAN
+
+TIMESROMAN
+.
+p
+@
+	
+p
+
+�
++
+A�
+
+�
+
+
+/;5!7>
+�
+
+
+
+	
+
+
+�
+0
+E
+
+
+�1	
+8
+&
+
3
+k
+#
+
+J
+9
+
+
+
+
+
+
+
+
+
+
+
+
+,
+^
+
+
+
+	
+	)
+)	
+
+	O
+
+
+
+�
+!
+$
+
+
+
+	
+
+
+	
+
+
+	
+
+
+
+
+
+_
+
+/
+n
+
+-
+
+
+c
+
+
+
+4
+F
+�
+-
+
+
+4
+
+s
+
+
+)
+:
+
+
+
+*
+
+		
+�
+
+�
++
+AE
+

+
+P
+
+	
+ 
+
+
+
+	
+
+0
+E
+
+
+

+4.

+
+6
+m
+
+
+
+
+

+	
+
+
+Z
+
+
+
+V
+_
+�
+
+&k
+	_
+!��z�
\ No newline at end of file
diff --git a/internal/library/DTEST.TEDIT b/internal/library/DTEST.TEDIT
new file mode 100644
index 00000000..1e2218e2
--- /dev/null
+++ b/internal/library/DTEST.TEDIT
@@ -0,0 +1 @@
+Running DSKTEST
The Disk-file-system test utility

1.	Load the file DSKTEST.DCOM from whichever directory & server it is stored on.
2.	Type
	(DSKTEST '{DSK}<LISPFILES> 
\ No newline at end of file
diff --git a/internal/library/DUMPFILE b/internal/library/DUMPFILE
new file mode 100644
index 00000000..781d32da
--- /dev/null
+++ b/internal/library/DUMPFILE
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "15-Jun-90 14:12:44" |{DSK}<usr>local>lde>lispcore>internal>library>DUMPFILE.;2| 10177  

      |changes| |to:|  (VARS DUMPFILECOMS)

      |previous| |date:| "16-Dec-88 19:00:26" 
|{DSK}<usr>local>lde>lispcore>internal>library>DUMPFILE.;1|)


; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT DUMPFILECOMS)

(RPAQQ DUMPFILECOMS (
                         (* |;;| "For dumping an octal/hex dump of a file")

                         (FNS DUMPFILE DUMPFILE.HEXBYTE DUMPFILE.NEWPAGE DUMPFILE.PRINTCHAR 
                              DUMPFILE.PRINTLINE)
                         (INITVARS (*PRINT-DOTS-FOR-UNPRINTABLE-CHARS*)
                                (*DUMPFILE-HEX-TABLE* "0123456789ABCDEF"))))



(* |;;| "For dumping an octal/hex dump of a file")

(DEFINEQ

(DUMPFILE
  (LAMBDA (FILE ST ND OUTFILE RADIX)                     (* \; "Edited 16-Dec-88 18:52 by jds")
                                                             (* \; "Octal/char file dump")
    (LET NIL (CL:WITH-OPEN-STREAM (OUTPUT-STREAM (COND
                                                    (OUTFILE (OPENIMAGESTREAM OUTFILE))
                                                    (T (\\GETSTREAM T 'OUTPUT))))
                    (CL:WITH-OPEN-STREAM (INPUT-STREAM (OR (OPENP FILE)
                                                           (OPENSTREAM FILE 'INPUT))
                                                X)
                           (STREAMPROP OUTPUT-STREAM 'INFILENAME (FULLNAME INPUT-STREAM))
                           (STREAMPROP OUTPUT-STREAM 'FILEDATE (DATE))
                           (STREAMPROP OUTPUT-STREAM 'HDGFONT '(TERMINAL 8 BOLD))
                           (STREAMPROP OUTPUT-STREAM 'MAINFONT '(TERMINAL 10))
                           (COND
                              ((IMAGESTREAMTYPEP OUTPUT-STREAM 'INTERPRESS)
                               (STREAMPROP OUTPUT-STREAM 'AFTERNEWPAGEFN (FUNCTION DUMPFILE.NEWPAGE))
                               (DSPLEFTMARGIN 2540 OUTPUT-STREAM)
                               (DSPRIGHTMARGIN 19050 OUTPUT-STREAM)
                               (DUMPFILE.NEWPAGE OUTPUT-STREAM)))
                           (PROG ((TERM10 (FONTCREATE 'TERMINAL 10 NIL NIL OUTPUT-STREAM))
                                  (TERM6 (FONTCREATE 'TERMINAL 6 NIL NIL OUTPUT-STREAM))
                                  (START (OR ST 0))
                                  (END (OR ND (GETEOFPTR INPUT-STREAM)))
                                  (CHARS (ARRAY 16 'SMALLP 0 0))
                                  CH \#CHARS)
                                 (SETFILEPTR INPUT-STREAM START)
                                 (|for| I |from| START |to| (SUB1 END) |by| 16
                                    |do| (SETQ \#CHARS (IMIN 15 (IDIFFERENCE (SUB1 END)
                                                                           I)))
                                          (\\BINS INPUT-STREAM (|fetch| (ARRAYP BASE)
                                                                  |of| CHARS)
                                                 0
                                                 (ADD1 \#CHARS))
                                          (DUMPFILE.PRINTLINE OUTPUT-STREAM I RADIX CHARS
                                                 (ADD1 \#CHARS)
                                                 TERM10 TERM6))))))))

(DUMPFILE.HEXBYTE
  (LAMBDA (OUTFILE WORD HEXBASE)                         (* \; "Edited  3-Dec-87 18:13 by jds")
          
          (* |;;| "Dump WORD as 4 hexadecimal digits onto OUTFILE.  HEXBASE is the pointer to byte 0 of a 16-byte table of character codes for the hex digits.")

    (\\OUTCHAR OUTFILE (\\GETBASEBYTE HEXBASE (LOGAND 15 (LRSH WORD 12))))
    (\\OUTCHAR OUTFILE (\\GETBASEBYTE HEXBASE (LOGAND 15 (LRSH WORD 8))))
    (\\OUTCHAR OUTFILE (\\GETBASEBYTE HEXBASE (LOGAND 15 (LRSH WORD 4))))
    (\\OUTCHAR OUTFILE (\\GETBASEBYTE HEXBASE (LOGAND 15 WORD)))))

(DUMPFILE.NEWPAGE
  (LAMBDA (OUTFILE)                                          (* |jds| " 9-Feb-86 17:41")
          
          (* * |Set| |up| |things| |for| \a |new| |page| |of| |the| |dump|)
          
          (* |Prints| \a |heading,| |moves| |to| |the| |first| |line's| |starting| 
          |spot,| |and| |sets| |the| |font| |back| |to| |Terminal| 10)

    (PROG ((FILEDATE (CONCAT "Dumped on:  " (STREAMPROP OUTFILE 'FILEDATE))))
          (MOVETO 2540 26670 OUTFILE)
          (DSPFONT (STREAMPROP OUTFILE 'HDGFONT)
                 OUTFILE)
          (PRINTOUT OUTFILE "Dump of file " (STREAMPROP OUTFILE 'INFILENAME))
          (MOVETO (IDIFFERENCE 19050 (STRINGWIDTH FILEDATE OUTFILE))
                 26670 OUTFILE)
          (PRIN1 FILEDATE OUTFILE)
          (DRAWLINE 2540 26635 19050 26635 35 'PAINT OUTFILE)
          (MOVETO 2540 25400 OUTFILE)
          (DSPFONT (STREAMPROP OUTFILE 'MAINFONT)
                 OUTFILE))))

(DUMPFILE.PRINTCHAR
  (LAMBDA (OUTFILE CHAR WASTERM10 TERM10 TERM6)              (* \; "Edited 28-Jul-87 18:08 by jds")

(* |;;;| "Print a single character in the char part of the listing")
                                                             (* \; 
                                                     "Returns T if it leaves OUTFILE in TERMINAL 10.")

    (PROG ((A10WIDTH (CHARWIDTH (CHARCODE A)
                            TERM10))
           (A6WIDTH (CHARWIDTH (CHARCODE A)
                           TERM6))
           (CURX (DSPXPOSITION NIL OUTFILE))
           (CURY (DSPYPOSITION NIL OUTFILE))
           (ASC10 (FONTPROP TERM10 'ASCENT))
           (ASC6 (FONTPROP TERM6 'ASCENT)))
          (COND
             ((AND *PRINT-DOTS-FOR-UNPRINTABLE-CHARS* (OR (ILEQ CHAR 31)
                                                          (IGEQ CHAR 127)))
              (\\OUTCHAR OUTFILE (CONSTANT (CHARCODE ".")))
              (SETQ WASTERM10 T))
             ((ILEQ CHAR 31)                                 (* \; 
                           "It's a control character;  print ^ & char in 6pt in 1 10pt char's block.")

              (SETQ WASTERM10 NIL)
              (DSPFONT TERM6 OUTFILE)
              (MOVETO CURX (IPLUS CURY (IDIFFERENCE ASC10 ASC6))
                     OUTFILE)
              (PRIN1 "^" OUTFILE)
              (MOVETO (IPLUS CURX (IDIFFERENCE A10WIDTH A6WIDTH))
                     CURY OUTFILE)
              (\\OUTCHAR OUTFILE (IPLUS CHAR 64)))
             ((IGEQ CHAR 127)                                (* \; 
                               "It's a special.  Print a name or ..  in 6pt in one 10pt char's block")

              (SETQ WASTERM10 NIL)
              (DSPFONT TERM6 OUTFILE)
              (PRIN1 "." OUTFILE)
              (MOVETO (IPLUS CURX (IDIFFERENCE A10WIDTH A6WIDTH))
                     CURY OUTFILE)
              (PRIN1 "." OUTFILE))
             (T                                              (* \; "Just print the character.")

                (OR WASTERM10 (DSPFONT TERM10 OUTFILE))      (* \; 
                                                     "Regular characters always print in Terminal 10")

                (SETQ WASTERM10 T)
                (\\OUTCHAR OUTFILE CHAR)))
          (RETURN WASTERM10))))

(DUMPFILE.PRINTLINE
  (LAMBDA (OUTFILE ADDR RADIX CHARS \#CHARS TERM10 TERM6)(* \; "Edited 16-Dec-88 18:39 by jds")

(* |;;;| "Print out one line of a file dump")

    (PROG ((BASE (|fetch| (ARRAYP BASE) |of| CHARS))
           (HEXBASE (|fetch| (STRINGP BASE) |of| *DUMPFILE-HEX-TABLE*))
           (WASTERM10 T))
          (SELECTQ RADIX
              (8 (|printout| OUTFILE |.I10.8| ADDR |,,,|))
              (16 (|for| I |from| 28 |to| 0 |by| -4
                     |do| (\\OUTCHAR OUTFILE (\\GETBASEBYTE HEXBASE (LOGAND 15 (LRSH ADDR I)))))
                  (|for| I |from| 1 |to| 3 |do| (\\OUTCHAR OUTFILE (CHARCODE SPACE))))
              (10 (|printout| OUTFILE |.I10| ADDR |,,,|))
              (|printout| OUTFILE |.I10.8| ADDR |,,,|))      (* \; 
                                        "Print the current file address for the start of this line")
          (|for| CH# |from| 0 |to| (SELECTQ RADIX
                                                   (16 (SUB1 (LRSH (ADD1 \#CHARS)
                                                                   1)))
                                                   (SUB1 \#CHARS))
             |do| (SELECTQ RADIX
                          (8 (|printout| OUTFILE |.I4.8| (\\GETBASEBYTE BASE CH#)))
                          (16 (\\OUTCHAR OUTFILE (CHARCODE SPACE))
                              (DUMPFILE.HEXBYTE OUTFILE (\\GETBASE BASE CH#)
                                     HEXBASE))
                          (10 (|printout| OUTFILE |.I4| (\\GETBASEBYTE BASE CH#)))
                          (|printout| OUTFILE |.I4.8| (\\GETBASEBYTE BASE CH#))))
          (SPACES 3 OUTFILE)
          (PRIN1 "|" OUTFILE)
          (|for| CH# |from| 0 |to| (SUB1 \#CHARS) |do| (SETQ WASTERM10
                                                                        (DUMPFILE.PRINTCHAR
                                                                         OUTFILE
                                                                         (\\GETBASEBYTE BASE CH#)
                                                                         WASTERM10 TERM10 TERM6)))
          (COND
             ((NOT WASTERM10)                                (* \; 
 "If the last character was a special char, then we were left in terminal 6;  need to switch back.")
              (DSPFONT TERM10 OUTFILE)))
          (PRIN1 "|" OUTFILE)
          (TERPRI OUTFILE))))
)

(RPAQ? *PRINT-DOTS-FOR-UNPRINTABLE-CHARS* )

(RPAQ? *DUMPFILE-HEX-TABLE* "0123456789ABCDEF")
(PUTPROPS DUMPFILE COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (904 9977 (DUMPFILE 914 . 3560) (DUMPFILE.HEXBYTE 3562 . 4154) (DUMPFILE.NEWPAGE 4156 . 
5124) (DUMPFILE.PRINTCHAR 5126 . 7458) (DUMPFILE.PRINTLINE 7460 . 9975)))))
STOP
\ No newline at end of file
diff --git a/internal/library/FASL-DEBUG b/internal/library/FASL-DEBUG
new file mode 100644
index 00000000..e4216437
--- /dev/null
+++ b/internal/library/FASL-DEBUG
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO �READTABLE "INTERLISP" �PACKAGE "INTERLISP")
(FILECREATED " 3-Dec-86 12:01:43" {ERIS}<LISPCORE>INTERNAL>LIBRARY>FASL-DEBUG.;3 3296   

      changes to%:  (VARS FASL-DEBUGCOMS)
                    (FUNCTIONS FASL-LOAD DUMP-SOME-TEXT TEST-FASL-OUT DUMP-SOME-VALUES READ-BACK-FASL 
                           PROCESS-TEXT PROCESS-ITEM MAKE-FASL-TRACE-WINDOW)

      previous date%: "19-Sep-86 13:32:53" {ERIS}<LISPCORE>INTERNAL>LIBRARY>FASL-DEBUG.;1)


(* "
Copyright (c) 1986 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT FASL-DEBUGCOMS)

(RPAQQ FASL-DEBUGCOMS ((FUNCTIONS FASL-LOAD TEST-FASL-OUT DUMP-SOME-TEXT DUMP-SOME-VALUES 
                              READ-BACK-FASL PROCESS-TEXT PROCESS-ITEM MAKE-FASL-TRACE-WINDOW)
                       (PROP FILETYPE FASL-DEBUG)))

(CL:DEFUN FASL-LOAD (NAME) (CL:WITH-OPEN-FILE (S NAME :DIRECTION :INPUT)
                                  (FASL:PROCESS-FILE S)))


(CL:DEFUN TEST-FASL-OUT NIL (FASL:WITH-OPEN-HANDLE (HANDLE "test.dfasl;1" :IF-EXISTS :OVERWRITE)
                                   (DUMP-SOME-TEXT HANDLE "This is a test.")
                                   (DUMP-SOME-VALUES HANDLE)))


(CL:DEFUN DUMP-SOME-TEXT (HANDLE STRING) (CL:PRINC STRING (FASL:BEGIN-TEXT HANDLE)))


(CL:DEFUN DUMP-SOME-VALUES (HANDLE) (FASL:BEGIN-BLOCK HANDLE)
                                    (FASL:DUMP-VALUE HANDLE 1.1)
                                    (FASL:DUMP-VALUE HANDLE -1.1)
                                    (FASL:DUMP-VALUE HANDLE 0.11)
                                    (FASL:DUMP-VALUE HANDLE -0.11))


(CL:DEFUN READ-BACK-FASL (&OPTIONAL (NAME "test.dfasl")) [WITH-OPEN-FILE (S NAME :DIRECTION :INPUT)
                                                                (CL:UNLESS (EQL (BIN S)
                                                                                FASL:SIGNATURE)
                                                                       (CL:ERROR 
                                                                              "Incorrect signature.")
                                                                       )
                                                                (FASL:CHECK-VERSION S)
                                                                (CL:LOOP (CL:WHEN (EOFP S)
                                                                                (RETURN))
                                                                       (FASL:PROCESS-SEGMENT
                                                                        S
                                                                        #'PROCESS-TEXT
                                                                        #'PROCESS-ITEM])


(CL:DEFUN PROCESS-TEXT (S) (CL:PRINC S)
                           (CL:TERPRI))


(CL:DEFUN PROCESS-ITEM (X) (CL:FORMAT T "Value: ~S~%%" X))


(CL:DEFUN MAKE-FASL-TRACE-WINDOW NIL (LET ((W (CREATEW NIL "FASL trace")))
                                          (DSPSCROLL 'ON W)
                                          (CL:SETF FASL::DEBUG-STREAM (GETSTREAM W))))


(PUTPROPS FASL-DEBUG FILETYPE CL:COMPILE-FILE)
(PUTPROPS FASL-DEBUG COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/internal/library/FLOAT-ARRAY-SUPPORT b/internal/library/FLOAT-ARRAY-SUPPORT
new file mode 100644
index 00000000..60dc26ae
--- /dev/null
+++ b/internal/library/FLOAT-ARRAY-SUPPORT
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "15-Jun-90 14:17:57" 
{DSK}<usr>local>lde>lispcore>internal>library>FLOAT-ARRAY-SUPPORT.;2 7381   

      changes to%:  (VARS FLOAT-ARRAY-SUPPORTCOMS)

      previous date%: " 5-Dec-86 18:23:44" 
{DSK}<usr>local>lde>lispcore>internal>library>FLOAT-ARRAY-SUPPORT.;1)


(* ; "
Copyright (c) 1986, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT FLOAT-ARRAY-SUPPORTCOMS)

(RPAQQ FLOAT-ARRAY-SUPPORTCOMS
       ((FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
               UNBOXEDOPS)
        (FUNCTIONS %%BLKEXPONENT %%BLKFABSMAX %%BLKFABSMIN %%BLKFMAX %%BLKFMIN %%BLKFPLUS %%BLKFDIFF
               %%BLKFTIMES %%BLKPERM %%BLKSMALLP2FLOAT %%FLOATTOBYTE %%GET-FLOAT-ARRAY-BASE 
               %%INSURE-ARRAY %%MATMULT-133 %%MATMULT-144 %%MATMULT-331 %%MATMULT-333 %%MATMULT-441 
               %%MATMULT-444 %%MUL2 %%POLY-EVAL %%TEST-ARRAY MAKE-FLOAT-ARRAY MAKE-FLOAT-VECTOR 
               SINGLE-FLOAT-ARRAY-P SINGLE-FLOAT-VECTOR-P)
        (OPTIMIZERS %%POLY-EVAL %%MATMULT-133 %%MATMULT-144 %%MATMULT-331 %%MATMULT-333 %%MATMULT-441
               %%MATMULT-444)
        (PROP DOPVAL %%BLKEXPONENT %%BLKFABSMAX %%BLKFABSMIN %%BLKFDIFF %%BLKFMAX %%BLKFMIN 
              %%BLKFPLUS %%BLKFTIMES %%BLKPERM %%BLKSMALLP2FLOAT %%FLOATTOBYTE)
        (PROP FILETYPE FLOAT-ARRAY-SUPPORT)
        (DECLARE%: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD (LOCALVARS . T))))

(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES)
       UNBOXEDOPS)

(CL:DEFUN %%BLKEXPONENT (SOURCE DEST SIZE)
   (\MISC3.UFN SOURCE DEST SIZE 0))

(CL:DEFUN %%BLKFABSMAX (BASE ZERO SIZE)
   (\MISC3.UFN BASE ZERO SIZE 6))

(CL:DEFUN %%BLKFABSMIN (BASE ZERO SIZE)
   (\MISC3.UFN BASE ZERO SIZE 7))

(CL:DEFUN %%BLKFMAX (BASE ZERO SIZE)
   (\MISC3.UFN BASE ZERO SIZE 4))

(CL:DEFUN %%BLKFMIN (BASE ZERO SIZE)
   (\MISC3.UFN BASE ZERO SIZE 5))

(CL:DEFUN %%BLKFPLUS (SOURCE1 SOURCE2 DEST SIZE)
   (\MISC4.UFN SOURCE1 SOURCE2 DEST SIZE 2))

(CL:DEFUN %%BLKFDIFF (SOURCE1 SOURCE2 DEST SIZE)
   (\MISC4.UFN SOURCE1 SOURCE2 DEST SIZE 3))

(CL:DEFUN %%BLKFTIMES (SOURCE1 SOURCE2 DEST SIZE)
   (\MISC4.UFN SOURCE1 SOURCE2 DEST SIZE 0))

(CL:DEFUN %%BLKPERM (SOURCE PERMUTATION DEST SIZE)
   (\MISC4.UFN SOURCE PERMUTATION DEST SIZE 1))

(CL:DEFUN %%BLKSMALLP2FLOAT (SOURCE DEST SIZE)
   (\MISC3.UFN SOURCE DEST SIZE 2))

(CL:DEFUN %%FLOATTOBYTE (SOURCE DEST SIZE)
   (\MISC3.UFN SOURCE DEST SIZE 8))

(DEFMACRO %%GET-FLOAT-ARRAY-BASE (FLOAT-ARRAY)
   `(\ADDBASE (%%ARRAY-BASE ,FLOAT-ARRAY)
           (LLSH (%%ARRAY-OFFSET ,FLOAT-ARRAY)
                 1)))

(DEFMACRO %%INSURE-ARRAY (RESULT TEST-DIMS &OPTIONAL (MAKE-DIMS (LIST 'QUOTE TEST-DIMS)))
   `(CL:IF ,RESULT
        (%%TEST-ARRAY ,RESULT ,TEST-DIMS)
        (CL:MAKE-ARRAY ,MAKE-DIMS :ELEMENT-TYPE 'CL:SINGLE-FLOAT)))

(CL:DEFUN %%MATMULT-133 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
   (\UNBOXFLOAT3 MATRIXABASE MATRIXBBASE MATRIXCBASE 3))

(CL:DEFUN %%MATMULT-144 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
   (\UNBOXFLOAT3 MATRIXABASE MATRIXBBASE MATRIXCBASE 5))

(CL:DEFUN %%MATMULT-331 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
   (\UNBOXFLOAT3 MATRIXABASE MATRIXBBASE MATRIXCBASE 4))

(CL:DEFUN %%MATMULT-333 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
   (\UNBOXFLOAT3 MATRIXABASE MATRIXBBASE MATRIXCBASE 1))

(CL:DEFUN %%MATMULT-441 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
   (\UNBOXFLOAT3 MATRIXABASE MATRIXBBASE MATRIXCBASE 6))

(CL:DEFUN %%MATMULT-444 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
   (\UNBOXFLOAT3 MATRIXABASE MATRIXBBASE MATRIXCBASE 2))

(DEFMACRO %%MUL2 (X)
   `(LLSH ,X 1))

(CL:DEFUN %%POLY-EVAL (X BASE SIZE)
   (\FLOATBOX (\UNBOXFLOAT3 (\FLOATUNBOX X)
                     BASE SIZE 0)))

(DEFMACRO %%TEST-ARRAY (ARRAY DIMS)
   `(CL:IF [TYPEP ,ARRAY '(CL:ARRAY CL:SINGLE-FLOAT ,DIMS]
        ,ARRAY
        (CL:ERROR "Array of incorrect type: ~S" ,ARRAY)))

(DEFMACRO MAKE-FLOAT-ARRAY (DIMS &KEY INITIAL-ELEMENT)
   (CL:IF INITIAL-ELEMENT
       `(CL:MAKE-ARRAY ,DIMS :ELEMENT-TYPE 'CL:SINGLE-FLOAT :INITIAL-ELEMENT ,INITIAL-ELEMENT)
       `(CL:MAKE-ARRAY ,DIMS :ELEMENT-TYPE 'CL:SINGLE-FLOAT)))

(DEFMACRO MAKE-FLOAT-VECTOR (SIZE &KEY INITIAL-ELEMENT)
   (CL:IF INITIAL-ELEMENT
       `(MAKE-VECTOR ,SIZE :ELEMENT-TYPE 'CL:SINGLE-FLOAT :INITIAL-ELEMENT ,INITIAL-ELEMENT)
       `(MAKE-VECTOR ,SIZE :ELEMENT-TYPE 'CL:SINGLE-FLOAT)))

(DEFMACRO SINGLE-FLOAT-ARRAY-P (ARRAY)
   `(TYPEP ,ARRAY '(CL:ARRAY CL:SINGLE-FLOAT)))

(DEFMACRO SINGLE-FLOAT-VECTOR-P (ARRAY)
   `[TYPEP ,ARRAY '(CL:ARRAY CL:SINGLE-FLOAT (CL:*])

(DEFOPTIMIZER %%POLY-EVAL (X BASE SIZE)
                              `(\FLOATBOX ((OPCODES UBFLOAT3 0)
                                           (\FLOATUNBOX ,X)
                                           ,BASE
                                           ,SIZE)))

(DEFOPTIMIZER %%MATMULT-133 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
                                `((OPCODES UBFLOAT3 3)
                                  ,MATRIXABASE
                                  ,MATRIXBBASE
                                  ,MATRIXCBASE))

(DEFOPTIMIZER %%MATMULT-144 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
                                `((OPCODES UBFLOAT3 5)
                                  ,MATRIXABASE
                                  ,MATRIXBBASE
                                  ,MATRIXCBASE))

(DEFOPTIMIZER %%MATMULT-331 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
                                `((OPCODES UBFLOAT3 4)
                                  ,MATRIXABASE
                                  ,MATRIXBBASE
                                  ,MATRIXCBASE))

(DEFOPTIMIZER %%MATMULT-333 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
                                `((OPCODES UBFLOAT3 1)
                                  ,MATRIXABASE
                                  ,MATRIXBBASE
                                  ,MATRIXCBASE))

(DEFOPTIMIZER %%MATMULT-441 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
                                `((OPCODES UBFLOAT3 6)
                                  ,MATRIXABASE
                                  ,MATRIXBBASE
                                  ,MATRIXCBASE))

(DEFOPTIMIZER %%MATMULT-444 (MATRIXABASE MATRIXBBASE MATRIXCBASE)
                                `((OPCODES UBFLOAT3 2)
                                  ,MATRIXABASE
                                  ,MATRIXBBASE
                                  ,MATRIXCBASE))

(PUTPROPS %%BLKEXPONENT DOPVAL (3 MISC3 0))

(PUTPROPS %%BLKFABSMAX DOPVAL (3 MISC3 6))

(PUTPROPS %%BLKFABSMIN DOPVAL (3 MISC3 7))

(PUTPROPS %%BLKFDIFF DOPVAL (4 MISC4 3))

(PUTPROPS %%BLKFMAX DOPVAL (3 MISC3 4))

(PUTPROPS %%BLKFMIN DOPVAL (3 MISC3 5))

(PUTPROPS %%BLKFPLUS DOPVAL (4 MISC4 2))

(PUTPROPS %%BLKFTIMES DOPVAL (4 MISC4 0))

(PUTPROPS %%BLKPERM DOPVAL (4 MISC4 1))

(PUTPROPS %%BLKSMALLP2FLOAT DOPVAL (3 MISC3 2))

(PUTPROPS %%FLOATTOBYTE DOPVAL (3 MISC3 8))

(PUTPROPS FLOAT-ARRAY-SUPPORT FILETYPE CL:COMPILE-FILE)
(DECLARE%: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
)
(PUTPROPS FLOAT-ARRAY-SUPPORT COPYRIGHT ("Venue & Xerox Corporation" 1986 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/internal/library/GIVE-AND-TAKE b/internal/library/GIVE-AND-TAKE
new file mode 100644
index 00000000..2324cfb2
--- /dev/null
+++ b/internal/library/GIVE-AND-TAKE
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED " 3-Feb-91 14:11:40" |{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>GIVE-AND-TAKE.;4| 14607  

      |changes| |to:|  (COMMANDS "take")
                       (FUNCTIONS TAKE-FILE)

      |previous| |date:| "15-Jun-90 14:20:18" 
|{PELE:MV:ENVOS}<LISPCORE>INTERNAL>LIBRARY>GIVE-AND-TAKE.;3|)


; Copyright (c) 1986, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT GIVE-AND-TAKECOMS)

(RPAQQ GIVE-AND-TAKECOMS ((COMMANDS "give?" "taken?" "give" "take" "steal")
                              (FUNCTIONS GIVE-OR-TAKE-FIND ADD-DEFAULT-REGISTRY SEND-STEAL-MESSAGE 
                                     GIVE-FILE TAKE-FILE TAKEN?)
                              (VARIABLES *GIVE-AND-TAKE-DIRECTORIES*)
                              (PROP FILETYPE GIVE-AND-TAKE)))

(DEFCOMMAND "give?" NIL (TAKEN? :GIVE? T))

(DEFCOMMAND "taken?" (&REST ARGS) (CL:APPLY #'TAKEN? ARGS))

(DEFCOMMAND "give" (&REST FILES) (FOR FILE IN FILES ALWAYS (GIVE-FILE FILE)))

(DEFCOMMAND "take" (&REST FILES)

   (* |;;| "Give the issuer a \"lock\" on the files he asks for.  If you give more than one file name, it'll stop if it hits one you can't have the lock to.")

    (FOR FILE IN FILES ALWAYS (TAKE-FILE FILE)))

(DEFCOMMAND "steal" (&REST FILES) (FOR FILE IN FILES ALWAYS (TAKE-FILE FILE T)))

(CL:DEFUN GIVE-OR-TAKE-FIND (FILENAME)
   (LET ((NAME (FINDFILE FILENAME T *GIVE-AND-TAKE-DIRECTORIES*)))
        (COND
           (NAME NAME)
           (T (CL:FORMAT T "~A does not exist and so cannot be taken or given.~%" FILENAME)
              NIL))))

(CL:DEFUN ADD-DEFAULT-REGISTRY (NAME)

(* |;;;| "Adds default registry to NAME if there isn't one there already")

   (COND
      ((OR (STRPOS "." NAME)
           (NULL DEFAULTREGISTRY))
       NAME)
      (T (CONCAT NAME "." DEFAULTREGISTRY))))

(CL:DEFUN SEND-STEAL-MESSAGE (THIEF AUTHOR FILE)
   (LAFITE.SENDMESSAGE (MKSTRING (CL:FORMAT NIL 
               "Subject: File stolen
To: ~A

~A just stole the file ~A from you.

	The STEAL command" AUTHOR THIEF FILE))))

(CL:DEFUN GIVE-FILE (FILENAME)
   "Find the file named and look for a STATUS file associated with it.  If found and this user wrote it, then remove it, thus unlocking the file."
   (LET ((NAME (GIVE-OR-TAKE-FIND FILENAME))
         STATUS-STREAM TAKEN-BY)
        (COND
           ((NULL NAME)
            NIL)
           ((NOT (STREAMP (SETQ STATUS-STREAM (CAR (NLSETQ (OPENSTREAM (PACKFILENAME.STRING
                                                                        'EXTENSION
                                                                        'STATUS
                                                                        'VERSION 1 'BODY NAME)
                                                                  'INPUT NIL '(DON\'TCACHE)))))))
            (CL:FORMAT T "Sorry, but you can't give what you haven't taken.~%~A has not been taken by anyone, including you.~%"
                   NAME)
            NIL)
           ((STRING-EQUAL (SETQ TAKEN-BY (ADD-DEFAULT-REGISTRY (CL:READ STATUS-STREAM)))
                   (ADD-DEFAULT-REGISTRY (USERNAME)))    (* \; "We're a winner")
            (DELFILE (CLOSEF STATUS-STREAM))
            (CL:FORMAT T "~A is now unlocked.~%" NAME)
            T)
           (T                                                (* \; "We're a loser")
              (CL:FORMAT T 
                     "Sorry, but you can't give what you haven't taken.~%~A was taken by ~A on ~A.~%"
                     NAME TAKEN-BY (CL:READ STATUS-STREAM))
              (CLOSEF STATUS-STREAM)
              NIL))))

(CL:DEFUN TAKE-FILE (FILENAME &OPTIONAL STEAL)

   (* |;;| "Find the given file and open a status file to be associated with it.  If the file we open turns out to be version 1, then we've got the lock and we write our name and the date into the file.  Otherwise, somebody (possibly us!) has already got it and the lock cannot be obtained.  HOWEVER:  If we're the lock's owner already, indicate success -- the point is to grab the lock, not to find out if it's locked before!")

   (RESETLST
       (PROG ((GROSS-LIST-HACK (LIST NIL NIL T))
              NAME STATUS-NAME STATUS-NAME-PARTS STATUS-VERSION SUCCESS)
             (COND
                ((NOT (CL:SETF NAME (GIVE-OR-TAKE-FIND FILENAME)))
                 (RETURN NIL)))
             (CL:SETF STATUS-NAME (PACKFILENAME.STRING 'EXTENSION 'STATUS 'VERSION NIL 'BODY NAME))
             (CL:MACROLET ((STATUS-STREAM NIL '(CL:FIRST GROSS-LIST-HACK))
                           (STATUS-FULL-NAME NIL '(CL:SECOND GROSS-LIST-HACK))
                           (FINISHED-NORMALLY-P NIL '(CL:THIRD GROSS-LIST-HACK)))
                    (RESETSAVE NIL (LIST (FUNCTION (CL:LAMBDA (NAME GROSS-LIST-HACK)

                                            (* |;;| "We have been interrupted during processing.  Close any open streams and delete the status file we were making.")

                                                          (CL:WHEN (NOT (FINISHED-NORMALLY-P))
                                                              (CL:FORMAT T 
                                              "Interrupted during processing of ~A.  Take aborted.~%"
                                                                     NAME)
                                                              (CL:WHEN (AND (NULL (STATUS-FULL-NAME))
                                                                            (STREAMP (STATUS-STREAM))
                                                                            )
                                                             (* \; 
"If STATUS-FULL-NAME was never set, then STATUS-STREAM, if open, must refer to the new status file.")
                                                                  (CL:SETF (STATUS-FULL-NAME)
                                                                         (FULLNAME (STATUS-STREAM))))
                                                              (CL:IF (STREAMP (STATUS-STREAM))
                                                                  (CLOSEF? (STATUS-STREAM)))
                                                              (CL:IF (NOT (NULL (STATUS-FULL-NAME)))
                                                                  (DELFILE (STATUS-FULL-NAME))))))
                                         NAME GROSS-LIST-HACK))
                    (CL:SETF (STATUS-STREAM)
                           (OPENSTREAM STATUS-NAME 'OUTPUT NIL '(DON\'TCACHE)))
                    (CL:SETF (STATUS-FULL-NAME)
                           (FULLNAME (STATUS-STREAM)))
                    (COND
                       ((= (FILENAMEFIELD (STATUS-FULL-NAME)
                                  'VERSION)
                           1)                                (* \; "We're a winner")
                        (LET ((UNAME (ADD-DEFAULT-REGISTRY (USERNAME)))
                              (D (DATE)))
                             (CL:FORMAT (STATUS-STREAM)
                                    "~S ~S~%" UNAME D)
                             (CLOSEF (STATUS-STREAM))
                             (CL:FORMAT T "~A is now locked by ~A at ~A.~%" NAME UNAME D))
                        (LET ((ROOTNAME (ROOTFILENAME NAME))
                              INSTALLEDVERSION)
                             (COND
                                ((AND (GET ROOTNAME 'FILE)
                                      (NOT (STRING-EQUAL NAME (SETQ INSTALLEDVERSION
                                                               (CDAR (GET ROOTNAME 'FILEDATES))))))
                                 (CL:FORMAT T "Warning: File ~A is different from loaded file ~A~%" 
                                        NAME INSTALLEDVERSION))))
                        (CL:SETF SUCCESS T))
                       (T                                    (* \; "We're a loser at first blush ")
                                                             (* \; 
                                                      "(exception: we had the file locked already)")
                          (CLOSEF (STATUS-STREAM))
                          (DELFILE (STATUS-FULL-NAME))
                          (CL:SETF (STATUS-STREAM)
                                 (CAR (NLSETQ (OPENSTREAM (PACKFILENAME.STRING 'VERSION 1
                                                                 'BODY
                                                                 (STATUS-FULL-NAME))
                                                     'INPUT NIL '(DON\'TCACHE)))))
                          (COND
                             ((NOT (STREAMP (STATUS-STREAM)))
                              (CL:FORMAT T "Bad situation: Illegal versions of the status file exist.~&Try again in a moment or try to fix the problem.~%"
                                     )
                              (CL:SETF SUCCESS NIL))
                             (STEAL 
                                    (* |;;| 
                           "If we're going to steal it, we should send the former locker a notice.")

                                    (CL:FORMAT T "Stealing ~A (and sending ~A a message about it).~%"
                                           NAME (GETFILEINFO (STATUS-STREAM)
                                                       'AUTHOR))
                                    (ADD.PROCESS `(SEND-STEAL-MESSAGE
                                                   ',(USERNAME NIL NIL T)
                                                   ',(GETFILEINFO (STATUS-STREAM)
                                                            'AUTHOR)
                                                   ',NAME))
                                    (CLOSEF (STATUS-STREAM))
                                    (DELFILE (FULLNAME (STATUS-STREAM)))
                                    (CL:SETF SUCCESS (TAKE-FILE FILENAME NIL)))
                             ((PROG1 (NOT (NLSETQ (LET ((TAKEN-BY (CL:READ (STATUS-STREAM)))
                                                        (TAKEN-ON (CL:READ (STATUS-STREAM))))
                                                       (CL:IF (STRING-EQUAL TAKEN-BY (
                                                                               ADD-DEFAULT-REGISTRY
                                                                                      (USERNAME)))
                                                           (PROGN (CL:FORMAT T 
                                                           "You've already had ~A taken, since ~A.~%"
                                                                         NAME TAKEN-ON)

                                                  (* |;;| "This case is really a success: We've got the lock.  Return T so the \"take\" command will keep going.")

                                                                  (CL:SETF SUCCESS T))
                                                           (CL:FORMAT T 
                                                     "Sorry, but ~A was already taken by ~A on ~A.~%"
                                                                  NAME TAKEN-BY TAKEN-ON)))))
                                  (CLOSEF (STATUS-STREAM)))
                              (CL:FORMAT T "Bad situation: Only an illegal status file exists.~%Try again in a moment or try to fix the problem.~%"
                                     )
                              (CL:SETF SUCCESS NIL)))))
                    (CL:SETF (FINISHED-NORMALLY-P)
                           T))
             (RETURN SUCCESS))))

(CL:DEFUN TAKEN? (&KEY ((:BY AUTHOR))
                           GIVE?)
   (COND
      ((NULL AUTHOR)
       (SETQ AUTHOR (USERNAME))
       (COND
          ((STRPOS "." AUTHOR)
           (SETQ AUTHOR (SUBSTRING AUTHOR 1 (SUB1 (STRPOS "." AUTHOR)))))))
      ((OR (STRING-EQUAL AUTHOR "ANY")
           (STRING-EQUAL AUTHOR "ALL")
           (STRING-EQUAL AUTHOR "*"))
       (SETQ AUTHOR NIL)))
   (|printout| T "Looking for files taken by " (OR AUTHOR "any")
          T)
   (|for| DIR |in| *GIVE-AND-TAKE-DIRECTORIES*
      |do| (RESETLST
                   (LET ((GEN (\\GENERATEFILES (PACKFILENAME.STRING 'DIRECTORY DIR 'NAME "*"
                                                      'EXTENSION "STATUS")
                                     '(AUTHOR CREATIONDATE)
                                     '(RESETLST)))
                         NEXT THISAUTHOR DIRPRINTED)
                        (|while| (SETQ NEXT (\\GENERATENEXTFILE GEN))
                           |when| (PROGN (SETQ THISAUTHOR (\\GENERATEFILEINFO GEN 'AUTHOR))
                                             (OR (NULL AUTHOR)
                                                 (STRPOS AUTHOR THISAUTHOR 1 NIL T NIL UPPERCASEARRAY
                                                        )))
                           |do| (COND
                                       ((NOT DIRPRINTED)
                                        (|printout| T T "   " DIR T)
                                        (SETQ DIRPRINTED T)))
                                 (|printout| T (FILENAMEFIELD NEXT 'NAME)
                                        16
                                        (\\GENERATEFILEINFO GEN 'CREATIONDATE)
                                        40 THISAUTHOR)
                                 (COND
                                    ((NOT GIVE?)
                                     (TERPRI T))
                                    ((EQ (ASKUSER NIL NIL "  Give? " NIL T)
                                         'Y)
                                     (GIVE-FILE (PACKFILENAME.STRING 'EXTENSION NIL 'VERSION NIL
                                                           'BODY NEXT)))))))))

(DEFGLOBALVAR *GIVE-AND-TAKE-DIRECTORIES* '("{Pele:mv:envos}<Lispcore>Sources>" 
                                                      "{Pele:mv:envos}<Lispcore>Library>" 
                                                      "{Pele:mv:envos}<Lispcore>Internal>Library>" 
                                                      "{Pele:mv:envos}<LispUsers>Lispcore>" 
                                                      "{Pele:mv:envos}<CmL>Test>"))

(PUTPROPS GIVE-AND-TAKE FILETYPE CL:COMPILE-FILE)
(PUTPROPS GIVE-AND-TAKE COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1991))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/internal/library/MACROTEST b/internal/library/MACROTEST
new file mode 100644
index 00000000..5b776177
--- /dev/null
+++ b/internal/library/MACROTEST
@@ -0,0 +1 @@
+(FILECREATED "18-Mar-86 21:13:28" {ERIS}<LISPCORE>LIBRARY>MACROTEST.;12 125367Q

      changes to:  (VARS MACROTESTCOMS)
                   (FNS !CHARTEST !CHARFILETEST !STRPOSTEST)

      previous date: " 7-Jul-85 12:18:31" {ERIS}<LISPCORE>LIBRARY>MACROTEST.;10)


(* Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT MACROTESTCOMS)

(RPAQQ MACROTESTCOMS ((E (RADIX 8))
                          (DECLARE: EVAL@COMPILE DONTCOPY (MACROS MTHELP MTCHECKSTK CKEQ CKFEQ 
                                                                 CKFUZZYEQ MTCHECK MTCHECK1))
                          (FNS !DIAGNOSE !DIAGNOSELP)
                          (* "Basic entries")
                          (INITVARS (ERRORMESSAGESTREAM T)
                                 (!MTALLOWINEXACTFLG T)
                                 (!MTUSERAIDFLG T))
                          (FNS !CKEQ !CKFEQ !CKFUZZYEQ !MRAID)
                          (* "Utility fns")
                          (FNS !CONSTEST !COPY !SMASH !APPENDTEST)
                          (FNS !INTERPTEST !CHECKARGS !CHECKLSTARARG !CHECKLSTARSETARG)
                          (* "CONS and RPLAC tests")
                          (FNS !GCTEST !GCTEST1 !GCTEST2 !GCTESTSETF !GCTESTSETG)
                          (* "Test of garbage collector")
                          (FNS MINILOGOUT)
                          (* "File MACROTESTAUX contains freevar and numeric tests")
                          (FNS !CHARTEST !STRPOSTEST !CHARFILETEST)
                          (DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (FILES MACROTESTAUX))))
(DECLARE: EVAL@COMPILE DONTCOPY 
(DECLARE: EVAL@COMPILE 
[PUTPROPS MTHELP MACRO (X (LIST (QUOTE !MRAID)
                                (COND ((CDR X)
                                       (CONS (QUOTE LIST)
                                             X))
                                      (T (CAR X]
[PUTPROPS MTCHECKSTK MACRO (ARGS (SUBPAIR (QUOTE (ARGS ID))
                                        (LIST ARGS (RAND 1 MAX.SMALLP))
                                        (QUOTE (OR (EQ (PROG1 ID . ARGS)
                                                       ID)
                                                   (RAID (QUOTE WRONG#PUSHED]
(PUTPROPS CKEQ MACRO ((FORM ANSWER)
                      ([LAMBDA (Password Result)
                              (DECLARE (LOCALVARS Password Result))
                              (OR (EQ Password (QUOTE 343Q))
                                  (RAID (QUOTE WRONG#PUSHED)))
                              (!CKEQ Result ANSWER (QUOTE FORM]
                       (QUOTE 343Q)
                       FORM)))
(PUTPROPS CKFEQ MACRO ((FORM ANSWER)
                       ([LAMBDA (Password Result)
                               (DECLARE (LOCALVARS Password Result))
                               (OR (EQ Password (QUOTE 343Q))
                                   (RAID (QUOTE WRONG#PUSHED)))
                               (!CKFEQ Result ANSWER (QUOTE FORM]
                        (QUOTE 343Q)
                        FORM)))
(PUTPROPS CKFUZZYEQ MACRO ((FORM ANSWER)
                           ([LAMBDA (Password Result)
                                   (DECLARE (LOCALVARS Password Result))
                                   (OR (EQ Password (QUOTE 343Q))
                                       (RAID (QUOTE WRONG#PUSHED)))
                                   (!CKFUZZYEQ Result ANSWER (QUOTE FORM]
                            (QUOTE 343Q)
                            FORM)))
[PUTPROPS MTCHECK MACRO (Y (CONS (QUOTE MTCHECKSTK)
                                 (MAPCAR Y (FUNCTION (LAMBDA (X)
                                                            (LIST (QUOTE MTCHECK1)
                                                                  X]
[PUTPROPS MTCHECK1 MACRO ((X)
                          (OR X (MTHELP (QUOTE (Failed: X]
)
)
(DEFINEQ

(!DIAGNOSE
  [LAMBDA NIL                                                (* JonL " 7-Nov-84 19:20")
    (!NUMBERTEST)
    (!FNUMTEST)
    (!MIXNUMTEST)
    (!GCTEST)
    (!CONSTEST)
    (!FVARTEST)
    (!INTERPTEST)
    (CHECKCONSPAGES])

(!DIAGNOSELP
  (LAMBDA NIL                                                (* JonL " 7-Nov-84 18:42")
    (PROG ((I 0))
      LP  (!DIAGNOSE)
          (\STOPDISPLAY)
          (\RELEASEWORKINGSET)
          (\STARTDISPLAY)
          (printout T "Pass " (add I 1)
		    " completed." T)
          (GO LP))))
)



(* "Basic entries")


(RPAQ? ERRORMESSAGESTREAM T)

(RPAQ? !MTALLOWINEXACTFLG T)

(RPAQ? !MTUSERAIDFLG T)
(DEFINEQ

(!CKEQ
  (LAMBDA (RESULT ANSWER FORM)                               (* JonL " 7-Nov-84 17:20")
    (OR (EQ RESULT ANSWER)
	(AND (EQ (NTYPX RESULT)
		 (NTYPX ANSWER))
	     (EQUAL RESULT ANSWER))
	(!MRAID (LIST FORM (QUOTE =>)
		      RESULT
		      (QUOTE should-have-been)
		      ANSWER)))))

(!CKFEQ
  (LAMBDA (RESULT ANSWER FORM)                               (* JonL " 7-Nov-84 17:20")
    (OR (AND (FLOATP RESULT)
	     (FEQP RESULT ANSWER))
	(!MRAID (LIST FORM (QUOTE =>)
		      RESULT
		      (QUOTE should-have-been)
		      ANSWER)))))

(!CKFUZZYEQ
  (LAMBDA (X Y)                                              (* JonL " 7-Nov-84 17:21")
                                                             (* Essentially FEQP except that the low-order bit is 
							     ignored.)
    (OR (AND (FLOATP X)
	     (FLOATP Y))
	(!MRAID "An arg to CKFUZZYEQ is non-FLOATP"))
    (AND (EQ (BITCLEAR (fetch (FLOATP LOWORD) of X)
		       1)
	     (BITCLEAR (fetch (FLOATP LOWORD) of Y)
		       1))
	 (OR (EQ (fetch (FLOATP HIWORD) of X)
		 (fetch (FLOATP HIWORD) of Y))
	     (AND (EQ 0 (fetch (FLOATP HIWORDNOSIGNBIT) of X))
		  (EQ 0 (fetch (FLOATP HIWORDNOSIGNBIT) of Y)))))))

(!MRAID
  (LAMBDA (MESS1 MESS2 FLG)                                  (* JonL " 7-Nov-84 17:28")
    (if !MTUSERAIDFLG
	then (RAID MESS1 MESS2 FLG)
      else (printout ERRORMESSAGESTREAM "[RAID-level error] " MESS1 MESS2 T))))
)



(* "Utility fns")

(DEFINEQ

(!CONSTEST
  (LAMBDA NIL                                                (* JonL " 7-Nov-84 19:18")
    (PROG (A B C D)
          (MTCHECKSTK (PROG1 NIL (SETQ A (CONS (QUOTE A)
					       (QUOTE B)))
			     (MTCHECK (EQ (CAR A)
					  (QUOTE A))
				      (EQ (CDR A)
					  (QUOTE B)))
			     (SETQ A (CONS (QUOTE A)
					   (SETQ B (QUOTE (D E F)))))
			     (MTCHECK (EQ (CAR A)
					  (QUOTE A))
				      (EQ (CDR A)
					  B))
			     (SETQ A (DOCOLLECT (CONS 1)))
			     (MTCHECK (EQUAL (CAR A)
					     (QUOTE (1)))
				      (EQ (CDR A)
					  A)
				      (EQ (\REFCNT A)
					  1)
				      (EQ (\REFCNT (CAR A))
					  1))
			     (for X on (CDR (for I from 1 to 400Q collect (CONS I)))
				do (MTCHECK (EQ (\REFCNT X)
						1))
				   (EQ (\REFCNT (CAR X))
				       1))
			     (SETQ D (for I from 0 to 1000Q collect (LIST I)))
			     (for X on D do (PROG ((Y (CDR X))
						   (AX (CAR X))
						   (AY (CADR X))
						   (DY (CDDR X)))
					          (OR Y (RETURN))
					          (MTCHECK (PROGN (swap (CAR X)
									(CAR Y))
								  (AND (EQ (CAR X)
									   AY)
								       (EQ (CAR Y)
									   AX))))
					          (MTCHECK (PROGN (swap (CDR Y)
									(CDR X))
								  (AND (EQ (CDR X)
									   DY)
								       (EQ (CDR Y)
									   Y))))
					          (MTCHECK (PROGN 
                                                             (* Now put them back)
								  (swap (CAR X)
									(CAR Y))
								  (swap (CDR Y)
									(CDR X))
								  (AND (EQ Y (CDR X))
								       (EQ (CAR X)
									   AX)
								       (EQ (CAR Y)
									   AY))))))
			     (for VAR in (LIST NIL D "A STRING")
				do (for X on D do (MTCHECK (EQ (PROG1 (CDR X)
								      (swap (CDR X)
									    VAR)
								      (swap (CDR X)
									    VAR))
							       (CDR X)))))
			     (for X on (CDR D) do (MTCHECK (EQ (\REFCNT X)
							       1)
							   (EQ (\REFCNT (CAR X))
							       1)))
			     (for I from 0 to 1000Q do (MTCHECK (EQUAL (pop D)
								       (LIST I))))
			     (for X
				in (QUOTE ((((A) . B))
					    (A B)
					    ((A B . C))
					    ((A B C D . E))
					    ((A . B)
					     (C . D)
					     (E . F)
					     ((((((((((((((G)))))))))))))))
					    (1 2 3 4 5 6 7 10Q 11Q 12Q 13Q 14Q 15Q 16Q 17Q 20Q 21Q 22Q
 23Q 24Q)))
				bind Y K Z
				do (MTCHECK (EQUAL X (SETQ Y (!COPY X))))
				   (MTCHECK (EQUAL X (SETQ Z (COPY X))))
				   (MTCHECK (EQUAL X (SETQ Z (!SMASH Z))))
				   (MTCHECK (EQUAL X (SETQ K (MAPCAR X (FUNCTION (LAMBDA (YY)
									 YY))))))))))))

(!COPY
  (LAMBDA (X)                                                (* lmm "25-FEB-81 21:47")
    (COND
      ((NLISTP X)
	X)
      (T (CONS (!COPY (CAR X))
	       (!COPY (CDR X)))))))

(!SMASH
  (LAMBDA (X)                                                (* bvm: "14-JAN-82 17:04")
    (COND
      ((LISTP X)
	(RPLACD (RPLACA X (!SMASH (CAR X)))
		(!SMASH (CDR X))))
      ((NULL X)
	(RPLACA (RPLACD X X)
		X))
      (T X))))

(!APPENDTEST
  (LAMBDA NIL                                                (* JonL "16-Dec-84 21:06")
    (to 1750Q do (MTCHECK (EQUAL (QUOTE (A B C D))
				 (APPEND (QUOTE (A B))
					 (QUOTE (C D))))))
    (to 1000Q do (MTCHECK (EQUAL (QUOTE (A B . C))
				 (APPEND (QUOTE (A B))
					 (QUOTE C)))))))
)
(DEFINEQ

(!INTERPTEST
  (LAMBDA NIL                                                (* lmm "30-MAY-83 19:40")
    (PROG (INTERPDEF ANON)
          (PUTD (QUOTE !INTERPTESTER)
		(SETQ INTERPDEF (LIST (QUOTE LAMBDA)
				      NIL
				      (QUOTE (!CHECKARGS)))))
          (for FORMAL in (QUOTE (NIL (A)
				     (A B)
				     (A B C)
				     (A B C D)
				     (A B C D E)
				     (A B C D E F)
				     N))
	     do (RPLACA (CDR INTERPDEF)
			FORMAL)
		(for ACTUAL in (QUOTE (NIL (1)
					   (1 2)
					   (1 2 3)
					   (1 2 3 4)
					   (1 2 3 4 5)
					   (1 2 3 4 5 6)))
		   do (SETQ ANON T)
		      (APPLY INTERPDEF ACTUAL)
		      (EVAL (CONS INTERPDEF ACTUAL))
		      (SETQ ANON)
		      (APPLY (QUOTE !INTERPTESTER)
			     ACTUAL)
		      (EVAL (CONS (QUOTE !INTERPTESTER)
				  ACTUAL))
		      (COND
			((EQ FORMAL (QUOTE N))
			  (APPLY (QUOTE (LAMBDA N (PROG ((I 1))
						    LP  (COND
							  ((NOT (IGREATERP I N))
							    (!CHECKLSTARARG I (ARG N I))
							    (SETQ I (ADD1 I))
							    (GO LP)))
						        (SETQ I 1)
						    LP2 (COND
							  ((NOT (IGREATERP I N))
							    (SETARG N I (IPLUS 310Q I))
							    (!CHECKLSTARSETARG I (ARG N I))
							    (SETQ I (ADD1 I))
							    (GO LP2))))))
				 ACTUAL)))))
          (PROG (A B C D)
	        (for PAIR in (QUOTE ((3 3)
				      (T T)
				      (NIL NIL)
				      ((SETQ FOOVAR 3)
				       3)
				      (A NIL)
				      (B NIL)
				      (C NIL)
				      (D NIL)
				      ((SETTOPVAL (QUOTE FOOVAR)
						  45Q)
				       45Q)
				      (FOOVAR 45Q)
				      ((SETQ A 47Q)
				       47Q)
				      ((SETQ B 57Q)
				       57Q)
				      ((SETQ C 102Q)
				       102Q)
				      (A 47Q)
				      (B 57Q)
				      (C 102Q)
				      ((PROG NIL
					     (RETURN 14Q))
				       14Q)
				      ((PROG NIL
					     (GO L1)
					 L1  (RETURN 145Q)
					     (RETURN 146Q)
					     (RETURN 147Q))
				       145Q)
				      ((PROG ((A 504Q))
					     (RETURN A))
				       504Q)
				      ((PROG ((A 1777Q)
					      (B 634Q))
					     (OR (AND (EQ A 1777Q)
						      (EQ B 634Q))
						 (MTHELP)))
				       NIL)))
		   do (OR (EQ (EVAL (CAR PAIR))
			      (CADR PAIR))
			  (MTHELP PAIR "TEST FAILED")))
	        (OR (AND (EQ A 47Q)
			 (EQ B 57Q)
			 (EQ C 102Q)
			 (EQ FOOVAR 45Q))
		    (MTHELP (QUOTE (COMPILEVAL))))))))

(!CHECKARGS
  (LAMBDA NIL
    (DECLARE (USEDFREE ACTUAL ANON FORMAL INTERPDEF A B C D E F N))
                                                             (* JonL " 7-Nov-84 17:15")
    (COND
      ((LISTP FORMAL)
	(for Y in FORMAL as (X _ ACTUAL) bind VAL by (CDR X)
	   do (COND
		((OR (NEQ (SETQ VAL (SELECTQ Y
					     (A A)
					     (B B)
					     (C C)
					     (D D)
					     (E E)
					     (F F)
					     (SHOULDNT)))
			  (CAR X))
		     (NEQ (SETQ VAL (EVALV Y))
			  (CAR X)))
		  (MTHELP Y "Free Value wrong - was " VAL "should be" (CAR X))))))
      (FORMAL (OR (AND (EQ (EVALV FORMAL)
			   (LENGTH ACTUAL))
		       (EQ N (EVALV FORMAL)))
		  (MTHELP (QUOTE ARGCOUNT)))
	      (for I from 1 to N as X in ACTUAL do (OR (EQ (ARG N I)
							   X)
						       (MTHELP (QUOTE ARG)
							       I)))))
    (PROG ((FRAME (REALSTKNTH -1 (QUOTE !CHECKARGS)))
	   SCANFRAME NARGS NAME)
          (OR FRAME (MTHELP "Interpreter frame not found"))
          (OR (EQ (COND
		    (ANON INTERPDEF)
		    (T (QUOTE !INTERPTESTER)))
		  (SETQ NAME (STKNAME FRAME)))
	      (MTHELP "Interpreter frame name wrong:" NAME))
          (for X in FORMAL
	     do (OR (EQP FRAME (SETQ SCANFRAME (STKSCAN X)))
		    (MTHELP "STKSCAN failed for var" X))
		(RELSTK SCANFRAME))
          (OR (IGEQ (SETQ NARGS (STKNARGS FRAME))
		    (LENGTH FORMAL))
	      (MTHELP "STKNARGS WRONG" NARGS))
          (RELSTK FRAME))))

(!CHECKLSTARARG
  (LAMBDA (I VAL)                                            (* bvm: "26-SEP-81 21:19")
    (OR (EQ VAL (CAR (NTH ACTUAL I)))
	(MTHELP "INTERPRETED ARG" I))))

(!CHECKLSTARSETARG
  (LAMBDA (I VAL)                                            (* bvm: "26-SEP-81 21:20")
    (OR (EQ VAL (IPLUS I 310Q))
	(MTHELP "INTERPRETED SETARG" I))))
)



(* "CONS and RPLAC tests")

(DEFINEQ

(!GCTEST
  [LAMBDA NIL                                                (* bvm: "30-NOV-81 17:23")
    (!GCTEST1)
    (!GCTEST2])

(!GCTEST1
  [LAMBDA NIL
    (DECLARE (GLOBALVARS !GV1 !GV2 !GV3))                    (* JonL "16-Mar-84 12:10")
    (PROG (A B C D E)
          (MTCHECK (PROGN (SETQ A (CONS 1 2))
			  (EQ (\REFCNT A)
			      0))
		   (PROGN (SETQ B (CONS A))
			  (AND (EQ (\REFCNT A)
				   1)
			       (EQ (\REFCNT B)
				   0)))
		   (PROGN (SETQ C (CONS A))
			  (AND (EQ (\REFCNT A)
				   2)
			       (EQ (\REFCNT C)
				   0)))
		   (PROGN (RPLACA B (QUOTE FOO))
			  (AND (EQ (\REFCNT A)
				   1)
			       (EQ (\REFCNT B)
				   0)))
		   (PROGN (RPLACA C (QUOTE FUM))
			  (AND (EQ (\REFCNT A)
				   0)
			       (EQ (\REFCNT C)
				   0)))
		   (PROGN (RPLACD C (SETQ D (CONS)))
			  (EQ (\REFCNT D)
			      1))
		   (PROGN (RPLACD C (SETQ E (CONS)))
			  (AND (EQ (\REFCNT D)
				   0)
			       (EQ (\REFCNT E)
				   1)))
		   (PROGN (SETQ !GV1 NIL)
			  (EQ (\REFCNT !GV1)
			      1))
		   (PROGN (SETQ !GV1 E)
			  (EQ (\REFCNT E)
			      2))
		   (PROGN (SETQ !GV1 A)
			  (AND (EQ (\REFCNT E)
				   1)
			       (EQ (\REFCNT A)
				   1)))
		   (PROGN (SETQ !GV3 A)
			  (EQ (\REFCNT A)
			      2))
		   (PROGN (SETQ !GV2 C)
			  (EQ (\REFCNT C)
			      1])

(!GCTEST2
  [LAMBDA NIL                                                (* JonL "16-Mar-84 14:03")
    (PROG ((A (CONS (QUOTE FOO)))
	   (I 0)
	   (REFARRAY (ARRAY 200Q (QUOTE POINTER)
			    NIL 0)))
          [RPTQ 106Q (MTCHECK (PROGN (SETA REFARRAY (add I 1)
					   A)
				     (EQ (\REFCNT A)
					 I]
          (RPTQ 106Q (MTCHECK (PROGN (SETA REFARRAY (PROG1 I (add I -1))
					   NIL)
				     (EQ (\REFCNT A)
					 I])

(!GCTESTSETF
  (LAMBDA NIL                                                (* JonL "16-Mar-84 12:17")
    (PROG ((A1 (VAG2 71Q 442Q))
	   (A2 (VAG2 72Q 442Q))
	   (A3 (VAG2 70Q 442Q))
	   (A4 (VAG2 67Q 442Q))
	   (A5 (VAG2 66Q 442Q)))                             (* 5 array pointers that will hash to same place)

          (* (PROG ((STATE (for X in (QUOTE (A1 A2 A3 A4 A5)) collect (LIST X 1))) FORMS FORM BOX1STATE BOX2STATE) 
	  (FRPTQ 12Q (FRPTQ 12Q (SETQ VAR (CAR (NTH STATE (RAND 1 5)))) (PROG NIL RETRY (SELECTQ (RAND 1 4) 
	  (1 (COND (BOX1STATE (COND ((ZEROP (CADR BOX1STATE)) (GO RETRY))) (add (CADR BOX1STATE) -1))) 
	  (add (CADR VAR) 1) (SETQ BOX1STATE VAR) (push FORMS (LIST (QUOTE SETQ) (QUOTE !FVAR1) (CAR VAR)))) 
	  (2 (COND (BOX2STATE (COND ((ZEROP (CADR BOX2STATE)) (GO RETRY))) (add (CADR BOX2STATE) -1))) 
	  (add (CADR VAR) 1) (SETQ BOX2STATE VAR) (push FORMS (LIST (QUOTE SETQ) (QUOTE !FVAR2) (CAR VAR)))) 
	  (3 (add (CADR VAR) 1) (push FORMS (LIST (QUOTE \ADDREF) (CAR VAR)))) (PROGN (COND ((ZEROP (CADR VAR)) 
	  (GO RETRY))) (add (CADR VAR) -1) (push FORMS (LIST (QUOTE \DELREF) (CAR VAR))))))) (push FORMS 
	  (CONS (QUOTE MTCHECK) (for X in STATE collect (LIST (QUOTE EQ) (LIST (QUOTE \REFCNT) (CAR X)) 
	  (CADR X)))))) (for X in STATE do (COND ((ZEROP (CADR X)) (push FORMS (LIST (QUOTE \ADDREF) (CAR X)))) 
	  (T (FRPTQ (SUB1 (CADR X)) (push FORMS (LIST (QUOTE \DELREF) (CAR X))))))) (RETURN (CONS (QUOTE PROGN) 
	  (REVERSE FORMS)))))


          (MTCHECKSTK (\DELREF A3)
		      (SETQ !FVAR2 A1)
		      (SETQ !FVAR1 A3)
		      (SETQ !FVAR2 A1)
		      (SETQ !FVAR1 A1)
		      (SETQ !FVAR2 A5)
		      (\ADDREF A1)
		      (SETQ !FVAR1 A2)
		      (\DELREF A1)
		      (\ADDREF A5)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   2)
			       (EQ (\REFCNT A3)
				   0)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   3))
		      (SETQ !FVAR1 A5)
		      (\ADDREF A4)
		      (\ADDREF A2)
		      (\ADDREF A5)
		      (SETQ !FVAR2 A5)
		      (SETQ !FVAR1 A4)
		      (\ADDREF A3)
		      (SETQ !FVAR1 A3)
		      (SETQ !FVAR2 A2)
		      (SETQ !FVAR2 A4)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   2)
			       (EQ (\REFCNT A3)
				   2)
			       (EQ (\REFCNT A4)
				   3)
			       (EQ (\REFCNT A5)
				   3))
		      (\ADDREF A5)
		      (SETQ !FVAR1 A2)
		      (SETQ !FVAR2 A4)
		      (SETQ !FVAR1 A5)
		      (SETQ !FVAR2 A5)
		      (\DELREF A1)
		      (SETQ !FVAR1 A1)
		      (\DELREF A1)
		      (\ADDREF A4)
		      (\DELREF A4)
		      (MTCHECK (EQ (\REFCNT A1)
				   0)
			       (EQ (\REFCNT A2)
				   2)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   2)
			       (EQ (\REFCNT A5)
				   5))
		      (SETQ !FVAR2 A5)
		      (\DELREF A4)
		      (SETQ !FVAR2 A5)
		      (\DELREF A3)
		      (\ADDREF A1)
		      (SETQ !FVAR1 A1)
		      (SETQ !FVAR2 A5)
		      (SETQ !FVAR2 A3)
		      (\DELREF A1)
		      (\DELREF A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   0)
			       (EQ (\REFCNT A2)
				   1)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   4))
		      (SETQ !FVAR2 A1)
		      (SETQ !FVAR2 A4)
		      (\DELREF A4)
		      (\ADDREF A1)
		      (SETQ !FVAR1 A3)
		      (SETQ !FVAR1 A5)
		      (\ADDREF A3)
		      (\ADDREF A1)
		      (\ADDREF A4)
		      (SETQ !FVAR2 A3)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   1)
			       (EQ (\REFCNT A3)
				   2)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   5))
		      (SETQ !FVAR2 A2)
		      (SETQ !FVAR1 A3)
		      (\ADDREF A5)
		      (SETQ !FVAR2 A1)
		      (SETQ !FVAR2 A5)
		      (\DELREF A2)
		      (SETQ !FVAR2 A2)
		      (\DELREF A2)
		      (SETQ !FVAR1 A5)
		      (SETQ !FVAR1 A3)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   2)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   5))
		      (\ADDREF A1)
		      (\DELREF A1)
		      (\ADDREF A5)
		      (\ADDREF A5)
		      (SETQ !FVAR1 A5)
		      (SETQ !FVAR1 A4)
		      (SETQ !FVAR1 A4)
		      (SETQ !FVAR1 A2)
		      (SETQ !FVAR2 A2)
		      (\ADDREF A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   2)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   7))
		      (\DELREF A5)
		      (SETQ !FVAR2 A5)
		      (\ADDREF A2)
		      (\ADDREF A1)
		      (\DELREF A1)
		      (\ADDREF A5)
		      (SETQ !FVAR1 A3)
		      (\ADDREF A2)
		      (SETQ !FVAR1 A3)
		      (\ADDREF A4)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   2)
			       (EQ (\REFCNT A3)
				   2)
			       (EQ (\REFCNT A4)
				   2)
			       (EQ (\REFCNT A5)
				   10Q))
		      (\ADDREF A2)
		      (\DELREF A5)
		      (\DELREF A3)
		      (SETQ !FVAR2 A5)
		      (SETQ !FVAR1 A4)
		      (SETQ !FVAR1 A2)
		      (SETQ !FVAR1 A5)
		      (\DELREF A5)
		      (SETQ !FVAR2 A5)
		      (SETQ !FVAR1 A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   4)
			       (EQ (\REFCNT A3)
				   0)
			       (EQ (\REFCNT A4)
				   2)
			       (EQ (\REFCNT A5)
				   6))
		      (SETQ !FVAR1 A5)
		      (SETQ !FVAR2 A5)
		      (\DELREF A2)
		      (SETQ !FVAR1 A1)
		      (SETQ !FVAR2 A2)
		      (SETQ !FVAR2 A1)
		      (\ADDREF A5)
		      (SETQ !FVAR2 A4)
		      (SETQ !FVAR1 A5)
		      (SETQ !FVAR2 A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   3)
			       (EQ (\REFCNT A3)
				   0)
			       (EQ (\REFCNT A4)
				   2)
			       (EQ (\REFCNT A5)
				   7))
		      (\DELREF A2)
		      (\DELREF A2)
		      (\ADDREF A3)
		      (\DELREF A4)
		      (\DELREF A5)
		      (\DELREF A5)
		      (\DELREF A5)
		      (\DELREF A5)
		      (\DELREF A5)
		      (\DELREF A5)
		      (SETQ.NOREF !FVAR1 NIL)
		      (SETQ.NOREF !FVAR2 NIL))
          (MTCHECKSTK (\DELREF A5)
		      (SETQ !FVAR1 A5)
		      (SETQ !FVAR2 A2)
		      (\ADDREF A1)
		      (SETQ !FVAR1 A2)
		      (\ADDREF A4)
		      (SETQ !FVAR1 A1)
		      (\DELREF A2)
		      (SETQ !FVAR2 A5)
		      (SETQ !FVAR1 A5)
		      (MTCHECK (EQ (\REFCNT A1)
				   2)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   2)
			       (EQ (\REFCNT A5)
				   2))
		      (\ADDREF A4)
		      (\DELREF A3)
		      (\ADDREF A3)
		      (\ADDREF A2)
		      (SETQ !FVAR1 A4)
		      (\ADDREF A4)
		      (\DELREF A2)
		      (\ADDREF A3)
		      (SETQ !FVAR1 A2)
		      (\ADDREF A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   2)
			       (EQ (\REFCNT A2)
				   2)
			       (EQ (\REFCNT A3)
				   2)
			       (EQ (\REFCNT A4)
				   4)
			       (EQ (\REFCNT A5)
				   1))
		      (SETQ !FVAR2 A1)
		      (SETQ !FVAR1 A3)
		      (SETQ !FVAR2 A1)
		      (SETQ !FVAR2 A3)
		      (SETQ !FVAR1 A2)
		      (SETQ !FVAR2 A4)
		      (\DELREF A2)
		      (SETQ !FVAR2 A2)
		      (SETQ !FVAR2 A5)
		      (SETQ !FVAR2 A4)
		      (MTCHECK (EQ (\REFCNT A1)
				   2)
			       (EQ (\REFCNT A2)
				   1)
			       (EQ (\REFCNT A3)
				   2)
			       (EQ (\REFCNT A4)
				   5)
			       (EQ (\REFCNT A5)
				   0))
		      (\ADDREF A3)
		      (SETQ !FVAR2 A1)
		      (\DELREF A1)
		      (\ADDREF A5)
		      (\ADDREF A5)
		      (\ADDREF A4)
		      (SETQ !FVAR2 A4)
		      (SETQ !FVAR1 A5)
		      (\ADDREF A4)
		      (SETQ !FVAR2 A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   1)
			       (EQ (\REFCNT A3)
				   3)
			       (EQ (\REFCNT A4)
				   6)
			       (EQ (\REFCNT A5)
				   3))
		      (SETQ !FVAR2 A2)
		      (\ADDREF A1)
		      (SETQ !FVAR1 A5)
		      (SETQ !FVAR1 A4)
		      (SETQ !FVAR2 A5)
		      (\DELREF A3)
		      (\ADDREF A3)
		      (SETQ !FVAR2 A5)
		      (SETQ !FVAR2 A4)
		      (\ADDREF A3)
		      (MTCHECK (EQ (\REFCNT A1)
				   2)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   4)
			       (EQ (\REFCNT A4)
				   10Q)
			       (EQ (\REFCNT A5)
				   2))
		      (\DELREF A3)
		      (\ADDREF A4)
		      (\ADDREF A5)
		      (SETQ !FVAR2 A1)
		      (\ADDREF A1)
		      (\ADDREF A4)
		      (\ADDREF A2)
		      (\DELREF A4)
		      (SETQ !FVAR2 A2)
		      (\DELREF A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   3)
			       (EQ (\REFCNT A2)
				   1)
			       (EQ (\REFCNT A3)
				   3)
			       (EQ (\REFCNT A4)
				   10Q)
			       (EQ (\REFCNT A5)
				   3))
		      (SETQ !FVAR1 A2)
		      (SETQ !FVAR2 A1)
		      (SETQ !FVAR1 A5)
		      (SETQ !FVAR1 A3)
		      (\DELREF A3)
		      (SETQ !FVAR1 A1)
		      (\ADDREF A4)
		      (\ADDREF A4)
		      (\DELREF A3)
		      (SETQ !FVAR1 A1)
		      (MTCHECK (EQ (\REFCNT A1)
				   5)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   11Q)
			       (EQ (\REFCNT A5)
				   3))
		      (SETQ !FVAR2 A1)
		      (\ADDREF A4)
		      (SETQ !FVAR1 A3)
		      (SETQ !FVAR2 A3)
		      (SETQ !FVAR1 A2)
		      (SETQ !FVAR1 A1)
		      (SETQ !FVAR2 A2)
		      (SETQ !FVAR1 A5)
		      (SETQ !FVAR1 A5)
		      (SETQ !FVAR2 A5)
		      (MTCHECK (EQ (\REFCNT A1)
				   3)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   12Q)
			       (EQ (\REFCNT A5)
				   5))
		      (SETQ !FVAR1 A3)
		      (SETQ !FVAR2 A3)
		      (\ADDREF A2)
		      (SETQ !FVAR2 A5)
		      (\ADDREF A4)
		      (\DELREF A1)
		      (SETQ !FVAR1 A4)
		      (\DELREF A1)
		      (\DELREF A2)
		      (\ADDREF A5)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   14Q)
			       (EQ (\REFCNT A5)
				   5))
		      (\ADDREF A1)
		      (SETQ !FVAR2 A3)
		      (SETQ !FVAR1 A4)
		      (SETQ !FVAR1 A3)
		      (SETQ !FVAR2 A1)
		      (SETQ !FVAR1 A2)
		      (\ADDREF A4)
		      (\ADDREF A4)
		      (\ADDREF A4)
		      (\ADDREF A1)
		      (MTCHECK (EQ (\REFCNT A1)
				   4)
			       (EQ (\REFCNT A2)
				   1)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   16Q)
			       (EQ (\REFCNT A5)
				   4))
		      (\DELREF A1)
		      (\DELREF A1)
		      (\DELREF A1)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A4)
		      (\DELREF A5)
		      (\DELREF A5)
		      (\DELREF A5)
		      (SETQ.NOREF !FVAR1 NIL)
		      (SETQ.NOREF !FVAR2 NIL)))))

(!GCTESTSETG
  (LAMBDA NIL                                                (* JonL "16-Mar-84 12:17")
    (DECLARE (GLOBALVARS !GVAR1 !GVAR2))
    (PROG ((A1 (VAG2 71Q 442Q))
	   (A2 (VAG2 72Q 442Q))
	   (A3 (VAG2 70Q 442Q))
	   (A4 (VAG2 67Q 442Q))
	   (A5 (VAG2 66Q 442Q)))                             (* 5 array pointers that will hash to same place)

          (* (PROG ((STATE (for X in (QUOTE (A1 A2 A3 A4 A5)) collect (LIST X 1))) FORMS FORM BOX1STATE BOX2STATE) 
	  (FRPTQ 12Q (FRPTQ 12Q (SETQ VAR (CAR (NTH STATE (RAND 1 5)))) (PROG NIL RETRY (SELECTQ (RAND 1 4) 
	  (1 (COND (BOX1STATE (COND ((ZEROP (CADR BOX1STATE)) (GO RETRY))) (add (CADR BOX1STATE) -1))) 
	  (add (CADR VAR) 1) (SETQ BOX1STATE VAR) (push FORMS (LIST (QUOTE SETQ) (QUOTE !GVAR1) (CAR VAR)))) 
	  (2 (COND (BOX2STATE (COND ((ZEROP (CADR BOX2STATE)) (GO RETRY))) (add (CADR BOX2STATE) -1))) 
	  (add (CADR VAR) 1) (SETQ BOX2STATE VAR) (push FORMS (LIST (QUOTE SETQ) (QUOTE !GVAR2) (CAR VAR)))) 
	  (3 (add (CADR VAR) 1) (push FORMS (LIST (QUOTE \ADDREF) (CAR VAR)))) (PROGN (COND ((ZEROP (CADR VAR)) 
	  (GO RETRY))) (add (CADR VAR) -1) (push FORMS (LIST (QUOTE \DELREF) (CAR VAR))))))) (push FORMS 
	  (CONS (QUOTE MTCHECK) (for X in STATE collect (LIST (QUOTE EQ) (LIST (QUOTE \REFCNT) (CAR X)) 
	  (CADR X)))))) (for X in STATE do (COND ((ZEROP (CADR X)) (push FORMS (LIST (QUOTE \ADDREF) (CAR X)))) 
	  (T (FRPTQ (SUB1 (CADR X)) (push FORMS (LIST (QUOTE \DELREF) (CAR X))))))) (RETURN (CONS (QUOTE PROGN) 
	  (REVERSE FORMS)))))


          (MTCHECKSTK (SETQ !GVAR1 A4)
		      (\DELREF A2)
		      (SETQ !GVAR1 A4)
		      (\ADDREF A3)
		      (SETQ !GVAR1 A4)
		      (SETQ !GVAR2 A4)
		      (SETQ !GVAR2 A5)
		      (SETQ !GVAR1 A2)
		      (\DELREF A2)
		      (\DELREF A3)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   2))
		      (\DELREF A3)
		      (SETQ !GVAR2 A1)
		      (\ADDREF A4)
		      (SETQ !GVAR2 A5)
		      (SETQ !GVAR2 A2)
		      (\ADDREF A3)
		      (SETQ !GVAR1 A2)
		      (\DELREF A4)
		      (\DELREF A1)
		      (\DELREF A4)
		      (MTCHECK (EQ (\REFCNT A1)
				   0)
			       (EQ (\REFCNT A2)
				   1)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   0)
			       (EQ (\REFCNT A5)
				   1))
		      (\DELREF A2)
		      (\ADDREF A2)
		      (\DELREF A3)
		      (\ADDREF A1)
		      (SETQ !GVAR2 A1)
		      (\ADDREF A5)
		      (SETQ !GVAR2 A4)
		      (\ADDREF A5)
		      (\ADDREF A5)
		      (\ADDREF A1)
		      (MTCHECK (EQ (\REFCNT A1)
				   2)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   0)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   4))
		      (SETQ !GVAR2 A4)
		      (\ADDREF A5)
		      (SETQ !GVAR2 A5)
		      (\ADDREF A1)
		      (SETQ !GVAR2 A5)
		      (SETQ !GVAR2 A2)
		      (SETQ !GVAR1 A4)
		      (SETQ !GVAR1 A4)
		      (\DELREF A4)
		      (\ADDREF A4)
		      (MTCHECK (EQ (\REFCNT A1)
				   3)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   0)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   5))
		      (\DELREF A5)
		      (SETQ !GVAR1 A5)
		      (\ADDREF A4)
		      (\ADDREF A1)
		      (SETQ !GVAR1 A1)
		      (\DELREF A4)
		      (SETQ !GVAR1 A5)
		      (SETQ !GVAR1 A2)
		      (\ADDREF A3)
		      (SETQ !GVAR1 A1)
		      (MTCHECK (EQ (\REFCNT A1)
				   5)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   0)
			       (EQ (\REFCNT A5)
				   4))
		      (\ADDREF A2)
		      (\DELREF A3)
		      (SETQ !GVAR2 A4)
		      (SETQ !GVAR2 A4)
		      (SETQ !GVAR2 A3)
		      (SETQ !GVAR2 A2)
		      (\ADDREF A2)
		      (SETQ !GVAR2 A5)
		      (\ADDREF A4)
		      (\DELREF A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   5)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   0)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   5))
		      (SETQ !GVAR1 A2)
		      (SETQ !GVAR1 A4)
		      (\ADDREF A3)
		      (\DELREF A4)
		      (SETQ !GVAR1 A2)
		      (SETQ !GVAR2 A4)
		      (\DELREF A1)
		      (SETQ !GVAR1 A3)
		      (SETQ !GVAR2 A1)
		      (SETQ !GVAR2 A5)
		      (MTCHECK (EQ (\REFCNT A1)
				   3)
			       (EQ (\REFCNT A2)
				   0)
			       (EQ (\REFCNT A3)
				   2)
			       (EQ (\REFCNT A4)
				   0)
			       (EQ (\REFCNT A5)
				   5))
		      (SETQ !GVAR2 A3)
		      (SETQ !GVAR1 A2)
		      (\ADDREF A1)
		      (\ADDREF A5)
		      (\ADDREF A2)
		      (\DELREF A5)
		      (\DELREF A2)
		      (\DELREF A1)
		      (\ADDREF A2)
		      (SETQ !GVAR2 A4)
		      (MTCHECK (EQ (\REFCNT A1)
				   3)
			       (EQ (\REFCNT A2)
				   2)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   4))
		      (\DELREF A1)
		      (\ADDREF A5)
		      (\DELREF A1)
		      (\DELREF A5)
		      (\DELREF A3)
		      (\ADDREF A3)
		      (SETQ !GVAR1 A1)
		      (SETQ !GVAR2 A2)
		      (\ADDREF A2)
		      (SETQ !GVAR2 A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   2)
			       (EQ (\REFCNT A2)
				   3)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   0)
			       (EQ (\REFCNT A5)
				   4))
		      (\ADDREF A3)
		      (\ADDREF A1)
		      (SETQ !GVAR2 A5)
		      (SETQ !GVAR1 A3)
		      (SETQ !GVAR2 A2)
		      (SETQ !GVAR1 A2)
		      (SETQ !GVAR2 A4)
		      (\DELREF A3)
		      (SETQ !GVAR2 A4)
		      (\DELREF A1)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   3)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   4))
		      (\DELREF A2)
		      (\DELREF A2)
		      (\DELREF A5)
		      (\DELREF A5)
		      (\DELREF A5)
		      (SETQ.NOREF !GVAR1 NIL)
		      (SETQ.NOREF !GVAR2 NIL))
          (MTCHECKSTK (\ADDREF A3)
		      (\DELREF A1)
		      (SETQ !GVAR2 A1)
		      (SETQ !GVAR1 A2)
		      (SETQ !GVAR2 A2)
		      (\ADDREF A3)
		      (SETQ !GVAR2 A3)
		      (\DELREF A5)
		      (SETQ !GVAR2 A4)
		      (\ADDREF A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   0)
			       (EQ (\REFCNT A2)
				   3)
			       (EQ (\REFCNT A3)
				   3)
			       (EQ (\REFCNT A4)
				   2)
			       (EQ (\REFCNT A5)
				   0))
		      (SETQ !GVAR1 A5)
		      (SETQ !GVAR2 A3)
		      (SETQ !GVAR1 A5)
		      (SETQ !GVAR1 A1)
		      (\DELREF A1)
		      (SETQ !GVAR2 A5)
		      (\ADDREF A1)
		      (SETQ !GVAR1 A1)
		      (\DELREF A4)
		      (SETQ !GVAR1 A4)
		      (MTCHECK (EQ (\REFCNT A1)
				   0)
			       (EQ (\REFCNT A2)
				   2)
			       (EQ (\REFCNT A3)
				   3)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   1))
		      (SETQ !GVAR2 A5)
		      (SETQ !GVAR1 A1)
		      (\ADDREF A5)
		      (\ADDREF A4)
		      (\DELREF A2)
		      (SETQ !GVAR2 A5)
		      (\DELREF A4)
		      (SETQ !GVAR1 A5)
		      (\ADDREF A2)
		      (SETQ !GVAR1 A4)
		      (MTCHECK (EQ (\REFCNT A1)
				   0)
			       (EQ (\REFCNT A2)
				   2)
			       (EQ (\REFCNT A3)
				   3)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   2))
		      (\DELREF A2)
		      (\DELREF A4)
		      (\DELREF A2)
		      (\ADDREF A2)
		      (SETQ !GVAR2 A2)
		      (\ADDREF A5)
		      (\ADDREF A2)
		      (\ADDREF A1)
		      (SETQ !GVAR2 A3)
		      (\ADDREF A5)
		      (MTCHECK (EQ (\REFCNT A1)
				   1)
			       (EQ (\REFCNT A2)
				   2)
			       (EQ (\REFCNT A3)
				   4)
			       (EQ (\REFCNT A4)
				   0)
			       (EQ (\REFCNT A5)
				   3))
		      (\ADDREF A2)
		      (\DELREF A5)
		      (\ADDREF A1)
		      (SETQ !GVAR2 A4)
		      (SETQ !GVAR2 A2)
		      (SETQ !GVAR2 A5)
		      (\DELREF A3)
		      (\ADDREF A2)
		      (SETQ !GVAR2 A1)
		      (\DELREF A5)
		      (MTCHECK (EQ (\REFCNT A1)
				   3)
			       (EQ (\REFCNT A2)
				   4)
			       (EQ (\REFCNT A3)
				   2)
			       (EQ (\REFCNT A4)
				   0)
			       (EQ (\REFCNT A5)
				   1))
		      (\DELREF A2)
		      (SETQ !GVAR2 A2)
		      (SETQ !GVAR2 A5)
		      (\ADDREF A1)
		      (SETQ !GVAR2 A2)
		      (\DELREF A3)
		      (\ADDREF A5)
		      (SETQ !GVAR2 A5)
		      (SETQ !GVAR2 A1)
		      (SETQ !GVAR2 A1)
		      (MTCHECK (EQ (\REFCNT A1)
				   4)
			       (EQ (\REFCNT A2)
				   3)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   0)
			       (EQ (\REFCNT A5)
				   2))
		      (\ADDREF A5)
		      (SETQ !GVAR2 A4)
		      (\DELREF A1)
		      (\ADDREF A3)
		      (\DELREF A3)
		      (SETQ !GVAR2 A2)
		      (SETQ !GVAR2 A2)
		      (\DELREF A2)
		      (\DELREF A5)
		      (\ADDREF A2)
		      (MTCHECK (EQ (\REFCNT A1)
				   2)
			       (EQ (\REFCNT A2)
				   4)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   0)
			       (EQ (\REFCNT A5)
				   2))
		      (SETQ !GVAR2 A1)
		      (\DELREF A1)
		      (\DELREF A5)
		      (SETQ !GVAR2 A1)
		      (SETQ !GVAR2 A2)
		      (\ADDREF A2)
		      (\ADDREF A4)
		      (SETQ !GVAR1 A4)
		      (SETQ !GVAR1 A5)
		      (\ADDREF A1)
		      (MTCHECK (EQ (\REFCNT A1)
				   2)
			       (EQ (\REFCNT A2)
				   5)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   0)
			       (EQ (\REFCNT A5)
				   2))
		      (SETQ !GVAR1 A4)
		      (SETQ !GVAR1 A4)
		      (\DELREF A5)
		      (\ADDREF A5)
		      (SETQ !GVAR2 A1)
		      (SETQ !GVAR2 A2)
		      (\DELREF A5)
		      (SETQ !GVAR1 A1)
		      (SETQ !GVAR2 A4)
		      (SETQ !GVAR2 A1)
		      (MTCHECK (EQ (\REFCNT A1)
				   4)
			       (EQ (\REFCNT A2)
				   4)
			       (EQ (\REFCNT A3)
				   1)
			       (EQ (\REFCNT A4)
				   0)
			       (EQ (\REFCNT A5)
				   0))
		      (SETQ !GVAR2 A4)
		      (\ADDREF A4)
		      (SETQ !GVAR2 A4)
		      (SETQ !GVAR1 A4)
		      (SETQ !GVAR2 A5)
		      (\ADDREF A3)
		      (SETQ !GVAR1 A4)
		      (\DELREF A4)
		      (\ADDREF A1)
		      (\ADDREF A5)
		      (MTCHECK (EQ (\REFCNT A1)
				   3)
			       (EQ (\REFCNT A2)
				   4)
			       (EQ (\REFCNT A3)
				   2)
			       (EQ (\REFCNT A4)
				   1)
			       (EQ (\REFCNT A5)
				   2))
		      (\DELREF A1)
		      (\DELREF A1)
		      (\DELREF A2)
		      (\DELREF A2)
		      (\DELREF A2)
		      (\DELREF A3)
		      (\DELREF A5)
		      (SETQ.NOREF !GVAR1 NIL)
		      (SETQ.NOREF !GVAR2 NIL)))))
)



(* "Test of garbage collector")

(DEFINEQ

(MINILOGOUT
  (LAMBDA NIL                                                (* bvm: "10-OCT-81 17:22")

          (* * This one works for hacking in the init.sysout)


    (\STOPDISPLAY)
    (LOGOUT0)
    (\STARTDISPLAY)
    (\DEVICEEVENT (QUOTE AFTERLOGOUT))))
)



(* "File MACROTESTAUX contains freevar and numeric tests")

(DEFINEQ

(!CHARTEST
  [LAMBDA NIL                                                      (* edited: 
                                                                       "18-Mar-86 20:47")
    (!STRPOSTEST)
    (!CHARFILETEST])

(!STRPOSTEST
  [LAMBDA NIL                                                      (* edited: 
                                                                       "18-Mar-86 18:53")
    (if [NOT (AND (EQ 4 (STRPOSL (QUOTE (A B))
                                   "LKDA"))
                      (NULL (STRPOSL (QUOTE (A B))
                                   "LKD�&s�"))
                      (EQ 2 (STRPOSL (QUOTE (�&s� A))
                                   "B�&s�AASD;FKJ"))
                      (EQ 2 (STRPOSL (QUOTE (�&s�))
                                   "B�&s�AASD;FKJ"]
        then (HELP])

(!CHARFILETEST
  [LAMBDA NIL                                                      (* edited: 
                                                                       "18-Mar-86 20:56")
    (LET ((OUT (OPENSTREAM (QUOTE {CORE}FOO)
                      (QUOTE OUTPUT)))
          (PICODE (CHARCODE GREEK,PI)))
         (PRIN1 (QUOTE A)
                OUT)
         (PRIN1 (CHARACTER PICODE)
                OUT)
         (TERPRI OUT)
         (PRIN1 (CHARACTER PICODE)
                OUT)
         (TAB 3 NIL OUT)
         (PRIN1 (CHARACTER PICODE)
                OUT)
         (CLOSEF OUT)
         (SETQ IN (OPENSTREAM (QUOTE {CORE}FOO)
                         (QUOTE INPUT)))
         (for C in (BQUOTE (A �&s� (\, (CHARACTER (CHARCODE EOL)))
                                      �&s�
                                      (\, (CHARACTER (CHARCODE SPACE)))
                                      (\, (CHARACTER (CHARCODE SPACE)))
                                      �&s�)) do (if (NEQ C (READC IN))
                                                     then (HELP)))
         (CLOSEF IN)
         (DELFILE (QUOTE {CORE}FOO])
)
(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY 
(FILESLOAD MACROTESTAUX)
)
(PUTPROPS MACROTEST COPYRIGHT ("Xerox Corporation" 3675Q 3676Q 3677Q 3700Q 3701Q 3702Q))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (7540Q 10734Q (!DIAGNOSE 7552Q . 10176Q) (!DIAGNOSELP 10200Q . 10732Q)) (11132Q 14363Q (
!CKEQ 11144Q . 11701Q) (!CKFEQ 11703Q . 12352Q) (!CKFUZZYEQ 12354Q . 13761Q) (!MRAID 13763Q . 14361Q))
 (14416Q 24333Q (!CONSTEST 14430Q . 22545Q) (!COPY 22547Q . 23104Q) (!SMASH 23106Q . 23551Q) (
!APPENDTEST 23553Q . 24331Q)) (24334Q 35631Q (!INTERPTEST 24346Q . 31567Q) (!CHECKARGS 31571Q . 35013Q
) (!CHECKLSTARARG 35015Q . 35323Q) (!CHECKLSTARSETARG 35325Q . 35627Q)) (35675Q 120247Q (!GCTEST 
35707Q . 36126Q) (!GCTEST1 36130Q . 41052Q) (!GCTEST2 41054Q . 42047Q) (!GCTESTSETF 42051Q . 71473Q) (
!GCTESTSETG 71475Q . 120245Q)) (120320Q 120772Q (MINILOGOUT 120332Q . 120770Q)) (121076Q 125074Q (
!CHARTEST 121110Q . 121466Q) (!STRPOSTEST 121470Q . 122653Q) (!CHARFILETEST 122655Q . 125072Q)))))
STOP
\ No newline at end of file
diff --git a/internal/library/MACROTESTAUX b/internal/library/MACROTESTAUX
new file mode 100644
index 00000000..896fd516
--- /dev/null
+++ b/internal/library/MACROTESTAUX
@@ -0,0 +1 @@
+(FILECREATED " 7-Jul-85 12:26:39" {ERIS}<LISPCORE>LIBRARY>MACROTESTAUX.;2 247232Q

      changes to:  (FNS !MIXNUMTEST)

      previous date: " 3-Dec-84 19:19:33" {ERIS}<LISPCORE>LIBRARY>MACROTESTAUX.;1)


(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT MACROTESTAUXCOMS)

(RPAQQ MACROTESTAUXCOMS [(E (RADIX 10Q))
	[DECLARE: EVAL@COMPILE DONTCOPY (P (LOADCOMP (QUOTE MACROTEST)))
		  (DECLARE: DONTEVAL@LOAD (P (RESETSAVE OPTIMIZATIONSOFF T]
	(COMS (* "Test out of free variables")
	      (FNS !FVARTEST PUSH.TEST CALLS.FIRSTARGTEST CALLS.LASTARGTEST CALLS.TOOFEWARGS 
		   FVAR.FREE FVAR.TEST FVAR.TEST2 FVAR.TEST3 FN.FIRSTARG.FVARS 
		   FN.FIRSTARG.PVARS.FVARS FN.LASTARG.FVARS FN.LASTARG.FVARS.PVARS FVAR.TESTN 
		   FN.FREE.SKIPPVARS FN.FREEPVAR FN.FVAR3 FN.FREEARG FN.FR1 FN.FR2 FN.FR3 FAULTTEST)
	      (VARS (F0 0)
		    (F1 1)
		    (F2 2)
		    (F3 3)
		    (F4 4)
		    (F5 5)
		    (F6 6)
		    (F7 7)
		    (F8 10Q)))
	(* "Test out of numeric capabilities")
	(FNS !NUMBERTEST !NUMTEST1 !NUMTEST2 !NUMTEST3 !NUMTEST4 !NUMTEST5 !NUMTEST6 !RANDNUMTEST 
	     !RANDNUMTEST1 !RANDNUMTEST2 !RANDNUMTEST3 !RANDNUMTEST4 !FNUMTEST !FNUMTEST1 !FNUMTEST2 
	     !FNUMTEST3 !FNUMTEST4 !FNUMTEST5 !MIXNUMTEST)
	(* "Compiler error may prevent some of the above functions from getting compiled")
	(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (MAPC (OR (FILEFNSLST (QUOTE MACROTESTAUX))
								     (QUOTE (PUSH.TEST)))
								 (FUNCTION (LAMBDA
									     (X)
									     (MOVD? (QUOTE NILL)
										    X])
(DECLARE: EVAL@COMPILE DONTCOPY 
(LOADCOMP (QUOTE MACROTEST))

(DECLARE: DONTEVAL@LOAD 
(RESETSAVE OPTIMIZATIONSOFF T)
)
)



(* "Test out of free variables")

(DEFINEQ

(!FVARTEST
  (LAMBDA NIL                                                (* JonL " 1-Jun-84 18:19")
    (PUSH.TEST)
    (CALLS.FIRSTARGTEST)
    (CALLS.LASTARGTEST)
    (CALLS.TOOFEWARGS)
    (FVAR.FREE)
    (FVAR.TEST)
    (FVAR.TEST2)
    (FVAR.TEST3)))

(PUSH.TEST
  (LAMBDA (I0 I1 I2 I3 I4)                                   (* JonL " 1-Jun-84 19:54")
    (PROG (P0 P1 P2 P3 P4 P5 P6 P7 P8)
          (PROGN (MTCHECKSTK (COND
			       ((NULL F0)
				 F0)))
		 (MTCHECKSTK (COND
			       ((NULL F1)
				 F1)))
		 (MTCHECKSTK (COND
			       ((NULL F2)
				 F2)))
		 (MTCHECKSTK (COND
			       ((NULL F3)
				 F3)))
		 (MTCHECKSTK (COND
			       ((NULL F4)
				 F4)))
		 (MTCHECKSTK (COND
			       ((NULL F5)
				 F5)))
		 (MTCHECKSTK (COND
			       ((NULL F6)
				 F6)))
		 (MTCHECKSTK (COND
			       ((NULL F7)
				 F7)))
		 (MTCHECKSTK (COND
			       ((NULL F8)
				 F8))))
          (PROGN (MTCHECKSTK (COND
			       ((NULL P0)
				 P0)))
		 (MTCHECKSTK (COND
			       ((NULL P1)
				 P1)))
		 (MTCHECKSTK (COND
			       ((NULL P7)
				 P7)))
		 (MTCHECKSTK (COND
			       ((NULL P8)
				 P8)))))))

(CALLS.FIRSTARGTEST
  (LAMBDA NIL                                                (* JonL " 1-Jun-84 18:19")
    (MTCHECK (EQ (FN.FIRSTARG.FVARS 1 2 3)
		 1)
	     (EQ (FN.FIRSTARG.PVARS.FVARS 1 2 3)
		 1))))

(CALLS.LASTARGTEST
  (LAMBDA NIL                                                (* JonL " 1-Jun-84 18:19")
    (MTCHECK (EQ (FN.LASTARG.FVARS 1 2 3 4 5 6 7 10Q 11Q 12Q 13Q 14Q 15Q 16Q 17Q)
		 17Q))
    (MTCHECK (EQ (FN.LASTARG.FVARS.PVARS 1 2 3 4 5 6 7 10Q 11Q 12Q 13Q 14Q 15Q 16Q 17Q)
		 17Q))))

(CALLS.TOOFEWARGS
  (LAMBDA NIL                                                (* JonL " 1-Jun-84 18:19")
    (MTCHECK (EQ (FN.FIRSTARG.PVARS.FVARS 1 2)
		 1)
	     (EQ (FN.FIRSTARG.PVARS.FVARS)
		 NIL)
	     (EQ (FN.LASTARG.FVARS 1 2 3 4 5 6 7 10Q 11Q 12Q 13Q 14Q 15Q 16Q)
		 NIL))))

(FVAR.FREE
  (LAMBDA NIL                                                (* JonL " 1-Jun-84 18:19")
    (PROGN (SETQ F0 144Q)
	   (SETQ F1 145Q)
	   (SETQ F2 146Q)
	   (SETQ F3 147Q)
	   (SETQ F4 150Q)
	   (SETQ F5 151Q)
	   (SETQ F6 152Q)
	   (SETQ F7 153Q)
	   (SETQ F8 154Q)
	   (MTCHECK (EQ F0 144Q)
		    (EQ F1 145Q)
		    (EQ F2 146Q)
		    (EQ F3 147Q)
		    (EQ F4 150Q)
		    (EQ F5 151Q)
		    (EQ F6 152Q)
		    (EQ F7 153Q)
		    (EQ F8 154Q))
	   (SETQ F0 0)
	   (SETQ F1 1)
	   (SETQ F2 2)
	   (SETQ F3 3)
	   (SETQ F4 4)
	   (SETQ F5 5)
	   (SETQ F6 6)
	   (SETQ F7 7)
	   (SETQ F8 10Q))))

(FVAR.TEST
  (LAMBDA (FLG)                                              (* JonL " 1-Jun-84 18:19")
    (PROG ((FREE.VAR.FLAG (QUOTE FREE.VALUE))
	   (FREE.VAR (QUOTE GARBAGE)))
          (DECLARE (SPECVARS . T))
          (FN.FR1)
          (MTCHECK (NULL FREE.VAR.FLAG))
          (MTCHECK (EQ FREE.VAR (QUOTE FREE.VALUE))))
    (PROG ((FREE.VAR.FLAG (QUOTE FREE.VALUE)))
          (DECLARE (SPECVARS . T))
          (FN.FR1)
          (MTCHECK (NULL FREE.VAR.FLAG))
          (MTCHECK (EQ FREE.VAR (QUOTE FREE.VALUE))))))

(FVAR.TEST2
  (LAMBDA NIL                                                (* lmm "31-JUL-81 15:58")
    (PROG ((FVAR1 1)
	   (FVAR2 2)
	   (FVAR3 3))
          (FVAR.TEST T))))

(FVAR.TEST3
  (LAMBDA NIL                                                (* lmm " 3-JAN-80 01:46")
    (FVAR.TESTN 1 2 3)))

(FN.FIRSTARG.FVARS
  (LAMBDA (X Y Z)                                            (* JonL " 1-Jun-84 18:32")
    (COND
      (NIL FREE.1)
      (NIL FREE.2)
      (NIL FREE.3)
      (T X))))

(FN.FIRSTARG.PVARS.FVARS
  (LAMBDA (X Y Z)                                            (* JonL " 1-Jun-84 18:33")
    (PROG (P D Q)
          (RETURN (COND
		    (P FREE.1)
		    (P FREE.2)
		    (P FREE.3)
		    (T X))))))

(FN.LASTARG.FVARS
  (LAMBDA (A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15)
                                                             (* JonL " 1-Jun-84 18:34")
    (COND
      (NIL FREE.1)
      (NIL FREE.2)
      (NIL FREE.3)
      (T A15))))

(FN.LASTARG.FVARS.PVARS
  (LAMBDA (A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 A12 A13 A14 A15)
                                                             (* JonL " 1-Jun-84 18:35")
    (PROG (P1 P2 P3)
          (RETURN (COND
		    (NIL FREE.1)
		    (NIL FREE.2)
		    (NIL FREE.3)
		    (T A15))))))

(FVAR.TESTN
  (LAMBDA (FVAR1 FVAR2 FVAR3)                                (* lmm " 3-JAN-80 01:46")
    (FVAR.TEST T)))

(FN.FREE.SKIPPVARS
  (LAMBDA NIL                                                (* bvm: "21-OCT-83 12:38")
    (PROG (FVAR1 FVAR2 FVAR3)
          ((OPCODES NOP)))
    (FN.FVAR3)))

(FN.FREEPVAR
  (LAMBDA NIL                                                (* bvm: "21-OCT-83 12:29")
    (PROG (FVAR3)
          (SETQ FVAR3 (QUOTE FREEPVAR.VALUE))
          (RETURN (FN.FVAR3)))))

(FN.FVAR3
  (LAMBDA NIL                                                (* bvm: "21-OCT-83 12:29")
    FVAR3))

(FN.FREEARG
  (LAMBDA (FVAR3)                                            (* lmm " 3-JAN-80 01:34")
    (FN.FVAR3)))

(FN.FR1
  (LAMBDA NIL                                                (* JonL " 1-Jun-84 18:19")
    (FN.FR2)
    (MTCHECK (EQ FREE.VAR (QUOTE FREE.VALUE)))))

(FN.FR2
  (LAMBDA NIL                                                (* JonL " 1-Jun-84 18:19")
    (FN.FR3)
    (MTCHECK (EQ FREE.VAR (QUOTE FREE.VALUE)))))

(FN.FR3
  (LAMBDA NIL                                                (* JonL " 1-Jun-84 18:19")
    (COND
      (FREE.VAR.FLAG (SETQ FREE.VAR FREE.VAR.FLAG)
		     (SETQ FREE.VAR.FLAG NIL))
      (T (MTCHECK (EQ FREE.VAR (QUOTE FREE.VALUE)))))))

(FAULTTEST
  (LAMBDA NIL                                                (* JonL " 1-Jun-84 18:19")
    (SETQ FAULTFVAR 144Q)
    (MTCHECK (EQ 144Q (PROGN (\RELEASEWORKINGSET)
			     FAULTFVAR)))))
)

(RPAQQ F0 0)

(RPAQQ F1 1)

(RPAQQ F2 2)

(RPAQQ F3 3)

(RPAQQ F4 4)

(RPAQQ F5 5)

(RPAQQ F6 6)

(RPAQQ F7 7)

(RPAQQ F8 10Q)



(* "Test out of numeric capabilities")

(DEFINEQ

(!NUMBERTEST
  (LAMBDA NIL                                                (* lmm "21-OCT-81 15:50")
    (!NUMTEST1)
    (!NUMTEST2)
    (!NUMTEST3)
    (!NUMTEST4)
    (!NUMTEST5)
    (!NUMTEST6)))

(!NUMTEST1
  (LAMBDA NIL                                                (* bvm: " 8-MAR-82 22:59")
    (MTCHECKSTK (CKEQ (IGREATERP 0 0)
		      NIL)
		(CKEQ (IPLUS 0 0)
		      0)
		(CKEQ (IDIFFERENCE 0 0)
		      0)
		(CKEQ (LOGOR 0 0)
		      0)
		(CKEQ (LOGAND 0 0)
		      0)
		(CKEQ (LOGXOR 0 0)
		      0)
		(CKEQ (IGREATERP 0 1)
		      NIL)
		(CKEQ (IPLUS 0 1)
		      1)
		(CKEQ (IDIFFERENCE 0 1)
		      -1)
		(CKEQ (LOGOR 0 1)
		      1)
		(CKEQ (LOGAND 0 1)
		      0)
		(CKEQ (LOGXOR 0 1)
		      1)
		(CKEQ (IGREATERP 0 -1)
		      T)
		(CKEQ (IPLUS 0 -1)
		      -1)
		(CKEQ (IDIFFERENCE 0 -1)
		      1)
		(CKEQ (LOGOR 0 -1)
		      -1)
		(CKEQ (LOGAND 0 -1)
		      0)
		(CKEQ (LOGXOR 0 -1)
		      -1)
		(CKEQ (IGREATERP 0 2)
		      NIL)
		(CKEQ (IPLUS 0 2)
		      2)
		(CKEQ (IDIFFERENCE 0 2)
		      -2)
		(CKEQ (LOGOR 0 2)
		      2)
		(CKEQ (LOGAND 0 2)
		      0)
		(CKEQ (LOGXOR 0 2)
		      2)
		(CKEQ (IGREATERP 0 -2)
		      T)
		(CKEQ (IPLUS 0 -2)
		      -2)
		(CKEQ (IDIFFERENCE 0 -2)
		      2)
		(CKEQ (LOGOR 0 -2)
		      -2)
		(CKEQ (LOGAND 0 -2)
		      0)
		(CKEQ (LOGXOR 0 -2)
		      -2)
		(CKEQ (IGREATERP 0 177777Q)
		      NIL)
		(CKEQ (IPLUS 0 177777Q)
		      177777Q)
		(CKEQ (IDIFFERENCE 0 177777Q)
		      -177777Q)
		(CKEQ (LOGOR 0 177777Q)
		      177777Q)
		(CKEQ (LOGAND 0 177777Q)
		      0)
		(CKEQ (LOGXOR 0 177777Q)
		      177777Q)
		(CKEQ (IGREATERP 0 -200000Q)
		      T)
		(CKEQ (IPLUS 0 -200000Q)
		      -200000Q)
		(CKEQ (IDIFFERENCE 0 -200000Q)
		      200000Q)
		(CKEQ (LOGOR 0 -200000Q)
		      -200000Q)
		(CKEQ (LOGAND 0 -200000Q)
		      0)
		(CKEQ (LOGXOR 0 -200000Q)
		      -200000Q)
		(CKEQ (IGREATERP 0 177776Q)
		      NIL)
		(CKEQ (IPLUS 0 177776Q)
		      177776Q)
		(CKEQ (IDIFFERENCE 0 177776Q)
		      -177776Q)
		(CKEQ (LOGOR 0 177776Q)
		      177776Q)
		(CKEQ (LOGAND 0 177776Q)
		      0)
		(CKEQ (LOGXOR 0 177776Q)
		      177776Q)
		(CKEQ (IGREATERP 0 -200001Q)
		      T)
		(CKEQ (IPLUS 0 -200001Q)
		      -200001Q)
		(CKEQ (IDIFFERENCE 0 -200001Q)
		      200001Q)
		(CKEQ (LOGOR 0 -200001Q)
		      -200001Q)
		(CKEQ (LOGAND 0 -200001Q)
		      0)
		(CKEQ (LOGXOR 0 -200001Q)
		      -200001Q)
		(CKEQ (IGREATERP 1 0)
		      T)
		(CKEQ (IPLUS 1 0)
		      1)
		(CKEQ (IDIFFERENCE 1 0)
		      1)
		(CKEQ (LOGOR 1 0)
		      1)
		(CKEQ (LOGAND 1 0)
		      0)
		(CKEQ (LOGXOR 1 0)
		      1)
		(CKEQ (IGREATERP 1 1)
		      NIL)
		(CKEQ (IPLUS 1 1)
		      2)
		(CKEQ (IDIFFERENCE 1 1)
		      0)
		(CKEQ (LOGOR 1 1)
		      1)
		(CKEQ (LOGAND 1 1)
		      1)
		(CKEQ (LOGXOR 1 1)
		      0)
		(CKEQ (IGREATERP 1 -1)
		      T)
		(CKEQ (IPLUS 1 -1)
		      0)
		(CKEQ (IDIFFERENCE 1 -1)
		      2)
		(CKEQ (LOGOR 1 -1)
		      -1)
		(CKEQ (LOGAND 1 -1)
		      1)
		(CKEQ (LOGXOR 1 -1)
		      -2)
		(CKEQ (IGREATERP 1 2)
		      NIL)
		(CKEQ (IPLUS 1 2)
		      3)
		(CKEQ (IDIFFERENCE 1 2)
		      -1)
		(CKEQ (LOGOR 1 2)
		      3)
		(CKEQ (LOGAND 1 2)
		      0)
		(CKEQ (LOGXOR 1 2)
		      3)
		(CKEQ (IGREATERP 1 -2)
		      T)
		(CKEQ (IPLUS 1 -2)
		      -1)
		(CKEQ (IDIFFERENCE 1 -2)
		      3)
		(CKEQ (LOGOR 1 -2)
		      -1)
		(CKEQ (LOGAND 1 -2)
		      0)
		(CKEQ (LOGXOR 1 -2)
		      -1)
		(CKEQ (IGREATERP 1 177777Q)
		      NIL)
		(CKEQ (IPLUS 1 177777Q)
		      200000Q)
		(CKEQ (IDIFFERENCE 1 177777Q)
		      -177776Q)
		(CKEQ (LOGOR 1 177777Q)
		      177777Q)
		(CKEQ (LOGAND 1 177777Q)
		      1)
		(CKEQ (LOGXOR 1 177777Q)
		      177776Q)
		(CKEQ (IGREATERP 1 -200000Q)
		      T)
		(CKEQ (IPLUS 1 -200000Q)
		      -177777Q)
		(CKEQ (IDIFFERENCE 1 -200000Q)
		      200001Q)
		(CKEQ (LOGOR 1 -200000Q)
		      -177777Q)
		(CKEQ (LOGAND 1 -200000Q)
		      0)
		(CKEQ (LOGXOR 1 -200000Q)
		      -177777Q)
		(CKEQ (IGREATERP 1 177776Q)
		      NIL)
		(CKEQ (IPLUS 1 177776Q)
		      177777Q)
		(CKEQ (IDIFFERENCE 1 177776Q)
		      -177775Q))))

(!NUMTEST2
  (LAMBDA NIL                                                (* bvm: " 8-MAR-82 22:59")
    (MTCHECKSTK (CKEQ (LOGOR 1 177776Q)
		      177777Q)
		(CKEQ (LOGAND 1 177776Q)
		      0)
		(CKEQ (LOGXOR 1 177776Q)
		      177777Q)
		(CKEQ (IGREATERP 1 -200001Q)
		      T)
		(CKEQ (IPLUS 1 -200001Q)
		      -200000Q)
		(CKEQ (IDIFFERENCE 1 -200001Q)
		      200002Q)
		(CKEQ (LOGOR 1 -200001Q)
		      -200001Q)
		(CKEQ (LOGAND 1 -200001Q)
		      1)
		(CKEQ (LOGXOR 1 -200001Q)
		      -200002Q)
		(CKEQ (IGREATERP -1 0)
		      NIL)
		(CKEQ (IPLUS -1 0)
		      -1)
		(CKEQ (IDIFFERENCE -1 0)
		      -1)
		(CKEQ (LOGOR -1 0)
		      -1)
		(CKEQ (LOGAND -1 0)
		      0)
		(CKEQ (LOGXOR -1 0)
		      -1)
		(CKEQ (IGREATERP -1 1)
		      NIL)
		(CKEQ (IPLUS -1 1)
		      0)
		(CKEQ (IDIFFERENCE -1 1)
		      -2)
		(CKEQ (LOGOR -1 1)
		      -1)
		(CKEQ (LOGAND -1 1)
		      1)
		(CKEQ (LOGXOR -1 1)
		      -2)
		(CKEQ (IGREATERP -1 -1)
		      NIL)
		(CKEQ (IPLUS -1 -1)
		      -2)
		(CKEQ (IDIFFERENCE -1 -1)
		      0)
		(CKEQ (LOGOR -1 -1)
		      -1)
		(CKEQ (LOGAND -1 -1)
		      -1)
		(CKEQ (LOGXOR -1 -1)
		      0)
		(CKEQ (IGREATERP -1 2)
		      NIL)
		(CKEQ (IPLUS -1 2)
		      1)
		(CKEQ (IDIFFERENCE -1 2)
		      -3)
		(CKEQ (LOGOR -1 2)
		      -1)
		(CKEQ (LOGAND -1 2)
		      2)
		(CKEQ (LOGXOR -1 2)
		      -3)
		(CKEQ (IGREATERP -1 -2)
		      T)
		(CKEQ (IPLUS -1 -2)
		      -3)
		(CKEQ (IDIFFERENCE -1 -2)
		      1)
		(CKEQ (LOGOR -1 -2)
		      -1)
		(CKEQ (LOGAND -1 -2)
		      -2)
		(CKEQ (LOGXOR -1 -2)
		      1)
		(CKEQ (IGREATERP -1 177777Q)
		      NIL)
		(CKEQ (IPLUS -1 177777Q)
		      177776Q)
		(CKEQ (IDIFFERENCE -1 177777Q)
		      -200000Q)
		(CKEQ (LOGOR -1 177777Q)
		      -1)
		(CKEQ (LOGAND -1 177777Q)
		      177777Q)
		(CKEQ (LOGXOR -1 177777Q)
		      -200000Q)
		(CKEQ (IGREATERP -1 -200000Q)
		      T)
		(CKEQ (IPLUS -1 -200000Q)
		      -200001Q)
		(CKEQ (IDIFFERENCE -1 -200000Q)
		      177777Q)
		(CKEQ (LOGOR -1 -200000Q)
		      -1)
		(CKEQ (LOGAND -1 -200000Q)
		      -200000Q)
		(CKEQ (LOGXOR -1 -200000Q)
		      177777Q)
		(CKEQ (IGREATERP -1 177776Q)
		      NIL)
		(CKEQ (IPLUS -1 177776Q)
		      177775Q)
		(CKEQ (IDIFFERENCE -1 177776Q)
		      -177777Q)
		(CKEQ (LOGOR -1 177776Q)
		      -1)
		(CKEQ (LOGAND -1 177776Q)
		      177776Q)
		(CKEQ (LOGXOR -1 177776Q)
		      -177777Q)
		(CKEQ (IGREATERP -1 -200001Q)
		      T)
		(CKEQ (IPLUS -1 -200001Q)
		      -200002Q)
		(CKEQ (IDIFFERENCE -1 -200001Q)
		      200000Q)
		(CKEQ (LOGOR -1 -200001Q)
		      -1)
		(CKEQ (LOGAND -1 -200001Q)
		      -200001Q)
		(CKEQ (LOGXOR -1 -200001Q)
		      200000Q)
		(CKEQ (IGREATERP 2 0)
		      T)
		(CKEQ (IPLUS 2 0)
		      2)
		(CKEQ (IDIFFERENCE 2 0)
		      2)
		(CKEQ (LOGOR 2 0)
		      2)
		(CKEQ (LOGAND 2 0)
		      0)
		(CKEQ (LOGXOR 2 0)
		      2)
		(CKEQ (IGREATERP 2 1)
		      T)
		(CKEQ (IPLUS 2 1)
		      3)
		(CKEQ (IDIFFERENCE 2 1)
		      1)
		(CKEQ (LOGOR 2 1)
		      3)
		(CKEQ (LOGAND 2 1)
		      0)
		(CKEQ (LOGXOR 2 1)
		      3)
		(CKEQ (IGREATERP 2 -1)
		      T)
		(CKEQ (IPLUS 2 -1)
		      1)
		(CKEQ (IDIFFERENCE 2 -1)
		      3)
		(CKEQ (LOGOR 2 -1)
		      -1)
		(CKEQ (LOGAND 2 -1)
		      2)
		(CKEQ (LOGXOR 2 -1)
		      -3)
		(CKEQ (IGREATERP 2 2)
		      NIL)
		(CKEQ (IPLUS 2 2)
		      4)
		(CKEQ (IDIFFERENCE 2 2)
		      0)
		(CKEQ (LOGOR 2 2)
		      2)
		(CKEQ (LOGAND 2 2)
		      2)
		(CKEQ (LOGXOR 2 2)
		      0)
		(CKEQ (IGREATERP 2 -2)
		      T)
		(CKEQ (IPLUS 2 -2)
		      0)
		(CKEQ (IDIFFERENCE 2 -2)
		      4)
		(CKEQ (LOGOR 2 -2)
		      -2)
		(CKEQ (LOGAND 2 -2)
		      2)
		(CKEQ (LOGXOR 2 -2)
		      -4)
		(CKEQ (IGREATERP 2 177777Q)
		      NIL)
		(CKEQ (IPLUS 2 177777Q)
		      200001Q)
		(CKEQ (IDIFFERENCE 2 177777Q)
		      -177775Q)
		(CKEQ (LOGOR 2 177777Q)
		      177777Q)
		(CKEQ (LOGAND 2 177777Q)
		      2)
		(CKEQ (LOGXOR 2 177777Q)
		      177775Q))))

(!NUMTEST3
  (LAMBDA NIL                                                (* bvm: " 8-MAR-82 23:00")
    (MTCHECKSTK (CKEQ (IGREATERP 2 -200000Q)
		      T)
		(CKEQ (IPLUS 2 -200000Q)
		      -177776Q)
		(CKEQ (IDIFFERENCE 2 -200000Q)
		      200002Q)
		(CKEQ (LOGOR 2 -200000Q)
		      -177776Q)
		(CKEQ (LOGAND 2 -200000Q)
		      0)
		(CKEQ (LOGXOR 2 -200000Q)
		      -177776Q)
		(CKEQ (IGREATERP 2 177776Q)
		      NIL)
		(CKEQ (IPLUS 2 177776Q)
		      200000Q)
		(CKEQ (IDIFFERENCE 2 177776Q)
		      -177774Q)
		(CKEQ (LOGOR 2 177776Q)
		      177776Q)
		(CKEQ (LOGAND 2 177776Q)
		      2)
		(CKEQ (LOGXOR 2 177776Q)
		      177774Q)
		(CKEQ (IGREATERP 2 -200001Q)
		      T)
		(CKEQ (IPLUS 2 -200001Q)
		      -177777Q)
		(CKEQ (IDIFFERENCE 2 -200001Q)
		      200003Q)
		(CKEQ (LOGOR 2 -200001Q)
		      -200001Q)
		(CKEQ (LOGAND 2 -200001Q)
		      2)
		(CKEQ (LOGXOR 2 -200001Q)
		      -200003Q)
		(CKEQ (IGREATERP -2 0)
		      NIL)
		(CKEQ (IPLUS -2 0)
		      -2)
		(CKEQ (IDIFFERENCE -2 0)
		      -2)
		(CKEQ (LOGOR -2 0)
		      -2)
		(CKEQ (LOGAND -2 0)
		      0)
		(CKEQ (LOGXOR -2 0)
		      -2)
		(CKEQ (IGREATERP -2 1)
		      NIL)
		(CKEQ (IPLUS -2 1)
		      -1)
		(CKEQ (IDIFFERENCE -2 1)
		      -3)
		(CKEQ (LOGOR -2 1)
		      -1)
		(CKEQ (LOGAND -2 1)
		      0)
		(CKEQ (LOGXOR -2 1)
		      -1)
		(CKEQ (IGREATERP -2 -1)
		      NIL)
		(CKEQ (IPLUS -2 -1)
		      -3)
		(CKEQ (IDIFFERENCE -2 -1)
		      -1)
		(CKEQ (LOGOR -2 -1)
		      -1)
		(CKEQ (LOGAND -2 -1)
		      -2)
		(CKEQ (LOGXOR -2 -1)
		      1)
		(CKEQ (IGREATERP -2 2)
		      NIL)
		(CKEQ (IPLUS -2 2)
		      0)
		(CKEQ (IDIFFERENCE -2 2)
		      -4)
		(CKEQ (LOGOR -2 2)
		      -2)
		(CKEQ (LOGAND -2 2)
		      2)
		(CKEQ (LOGXOR -2 2)
		      -4)
		(CKEQ (IGREATERP -2 -2)
		      NIL)
		(CKEQ (IPLUS -2 -2)
		      -4)
		(CKEQ (IDIFFERENCE -2 -2)
		      0)
		(CKEQ (LOGOR -2 -2)
		      -2)
		(CKEQ (LOGAND -2 -2)
		      -2)
		(CKEQ (LOGXOR -2 -2)
		      0)
		(CKEQ (IGREATERP -2 177777Q)
		      NIL)
		(CKEQ (IPLUS -2 177777Q)
		      177775Q)
		(CKEQ (IDIFFERENCE -2 177777Q)
		      -200001Q)
		(CKEQ (LOGOR -2 177777Q)
		      -1)
		(CKEQ (LOGAND -2 177777Q)
		      177776Q)
		(CKEQ (LOGXOR -2 177777Q)
		      -177777Q)
		(CKEQ (IGREATERP -2 -200000Q)
		      T)
		(CKEQ (IPLUS -2 -200000Q)
		      -200002Q)
		(CKEQ (IDIFFERENCE -2 -200000Q)
		      177776Q)
		(CKEQ (LOGOR -2 -200000Q)
		      -2)
		(CKEQ (LOGAND -2 -200000Q)
		      -200000Q)
		(CKEQ (LOGXOR -2 -200000Q)
		      177776Q)
		(CKEQ (IGREATERP -2 177776Q)
		      NIL)
		(CKEQ (IPLUS -2 177776Q)
		      177774Q)
		(CKEQ (IDIFFERENCE -2 177776Q)
		      -200000Q)
		(CKEQ (LOGOR -2 177776Q)
		      -2)
		(CKEQ (LOGAND -2 177776Q)
		      177776Q)
		(CKEQ (LOGXOR -2 177776Q)
		      -200000Q)
		(CKEQ (IGREATERP -2 -200001Q)
		      T)
		(CKEQ (IPLUS -2 -200001Q)
		      -200003Q)
		(CKEQ (IDIFFERENCE -2 -200001Q)
		      177777Q)
		(CKEQ (LOGOR -2 -200001Q)
		      -1)
		(CKEQ (LOGAND -2 -200001Q)
		      -200002Q)
		(CKEQ (LOGXOR -2 -200001Q)
		      200001Q)
		(CKEQ (IGREATERP 177777Q 0)
		      T)
		(CKEQ (IPLUS 177777Q 0)
		      177777Q)
		(CKEQ (IDIFFERENCE 177777Q 0)
		      177777Q)
		(CKEQ (LOGOR 177777Q 0)
		      177777Q)
		(CKEQ (LOGAND 177777Q 0)
		      0)
		(CKEQ (LOGXOR 177777Q 0)
		      177777Q)
		(CKEQ (IGREATERP 177777Q 1)
		      T)
		(CKEQ (IPLUS 177777Q 1)
		      200000Q)
		(CKEQ (IDIFFERENCE 177777Q 1)
		      177776Q)
		(CKEQ (LOGOR 177777Q 1)
		      177777Q)
		(CKEQ (LOGAND 177777Q 1)
		      1)
		(CKEQ (LOGXOR 177777Q 1)
		      177776Q)
		(CKEQ (IGREATERP 177777Q -1)
		      T)
		(CKEQ (IPLUS 177777Q -1)
		      177776Q)
		(CKEQ (IDIFFERENCE 177777Q -1)
		      200000Q)
		(CKEQ (LOGOR 177777Q -1)
		      -1)
		(CKEQ (LOGAND 177777Q -1)
		      177777Q)
		(CKEQ (LOGXOR 177777Q -1)
		      -200000Q)
		(CKEQ (IGREATERP 177777Q 2)
		      T)
		(CKEQ (IPLUS 177777Q 2)
		      200001Q)
		(CKEQ (IDIFFERENCE 177777Q 2)
		      177775Q)
		(CKEQ (LOGOR 177777Q 2)
		      177777Q)
		(CKEQ (LOGAND 177777Q 2)
		      2)
		(CKEQ (LOGXOR 177777Q 2)
		      177775Q)
		(CKEQ (IGREATERP 177777Q -2)
		      T)
		(CKEQ (IPLUS 177777Q -2)
		      177775Q)
		(CKEQ (IDIFFERENCE 177777Q -2)
		      200001Q)
		(CKEQ (LOGOR 177777Q -2)
		      -1))))

(!NUMTEST4
  (LAMBDA NIL                                                (* bvm: " 8-MAR-82 23:00")
    (MTCHECKSTK (CKEQ (LOGAND 177777Q -2)
		      177776Q)
		(CKEQ (LOGXOR 177777Q -2)
		      -177777Q)
		(CKEQ (IGREATERP 177777Q 177777Q)
		      NIL)
		(CKEQ (IPLUS 177777Q 177777Q)
		      377776Q)
		(CKEQ (IDIFFERENCE 177777Q 177777Q)
		      0)
		(CKEQ (LOGOR 177777Q 177777Q)
		      177777Q)
		(CKEQ (LOGAND 177777Q 177777Q)
		      177777Q)
		(CKEQ (LOGXOR 177777Q 177777Q)
		      0)
		(CKEQ (IGREATERP 177777Q -200000Q)
		      T)
		(CKEQ (IPLUS 177777Q -200000Q)
		      -1)
		(CKEQ (IDIFFERENCE 177777Q -200000Q)
		      377777Q)
		(CKEQ (LOGOR 177777Q -200000Q)
		      -1)
		(CKEQ (LOGAND 177777Q -200000Q)
		      0)
		(CKEQ (LOGXOR 177777Q -200000Q)
		      -1)
		(CKEQ (IGREATERP 177777Q 177776Q)
		      T)
		(CKEQ (IPLUS 177777Q 177776Q)
		      377775Q)
		(CKEQ (IDIFFERENCE 177777Q 177776Q)
		      1)
		(CKEQ (LOGOR 177777Q 177776Q)
		      177777Q)
		(CKEQ (LOGAND 177777Q 177776Q)
		      177776Q)
		(CKEQ (LOGXOR 177777Q 177776Q)
		      1)
		(CKEQ (IGREATERP 177777Q -200001Q)
		      T)
		(CKEQ (IPLUS 177777Q -200001Q)
		      -2)
		(CKEQ (IDIFFERENCE 177777Q -200001Q)
		      400000Q)
		(CKEQ (LOGOR 177777Q -200001Q)
		      -200001Q)
		(CKEQ (LOGAND 177777Q -200001Q)
		      177777Q)
		(CKEQ (LOGXOR 177777Q -200001Q)
		      -400000Q)
		(CKEQ (IGREATERP -200000Q 0)
		      NIL)
		(CKEQ (IPLUS -200000Q 0)
		      -200000Q)
		(CKEQ (IDIFFERENCE -200000Q 0)
		      -200000Q)
		(CKEQ (LOGOR -200000Q 0)
		      -200000Q)
		(CKEQ (LOGAND -200000Q 0)
		      0)
		(CKEQ (LOGXOR -200000Q 0)
		      -200000Q)
		(CKEQ (IGREATERP -200000Q 1)
		      NIL)
		(CKEQ (IPLUS -200000Q 1)
		      -177777Q)
		(CKEQ (IDIFFERENCE -200000Q 1)
		      -200001Q)
		(CKEQ (LOGOR -200000Q 1)
		      -177777Q)
		(CKEQ (LOGAND -200000Q 1)
		      0)
		(CKEQ (LOGXOR -200000Q 1)
		      -177777Q)
		(CKEQ (IGREATERP -200000Q -1)
		      NIL)
		(CKEQ (IPLUS -200000Q -1)
		      -200001Q)
		(CKEQ (IDIFFERENCE -200000Q -1)
		      -177777Q)
		(CKEQ (LOGOR -200000Q -1)
		      -1)
		(CKEQ (LOGAND -200000Q -1)
		      -200000Q)
		(CKEQ (LOGXOR -200000Q -1)
		      177777Q)
		(CKEQ (IGREATERP -200000Q 2)
		      NIL)
		(CKEQ (IPLUS -200000Q 2)
		      -177776Q)
		(CKEQ (IDIFFERENCE -200000Q 2)
		      -200002Q)
		(CKEQ (LOGOR -200000Q 2)
		      -177776Q)
		(CKEQ (LOGAND -200000Q 2)
		      0)
		(CKEQ (LOGXOR -200000Q 2)
		      -177776Q)
		(CKEQ (IGREATERP -200000Q -2)
		      NIL)
		(CKEQ (IPLUS -200000Q -2)
		      -200002Q)
		(CKEQ (IDIFFERENCE -200000Q -2)
		      -177776Q)
		(CKEQ (LOGOR -200000Q -2)
		      -2)
		(CKEQ (LOGAND -200000Q -2)
		      -200000Q)
		(CKEQ (LOGXOR -200000Q -2)
		      177776Q)
		(CKEQ (IGREATERP -200000Q 177777Q)
		      NIL)
		(CKEQ (IPLUS -200000Q 177777Q)
		      -1)
		(CKEQ (IDIFFERENCE -200000Q 177777Q)
		      -377777Q)
		(CKEQ (LOGOR -200000Q 177777Q)
		      -1)
		(CKEQ (LOGAND -200000Q 177777Q)
		      0)
		(CKEQ (LOGXOR -200000Q 177777Q)
		      -1)
		(CKEQ (IGREATERP -200000Q -200000Q)
		      NIL)
		(CKEQ (IPLUS -200000Q -200000Q)
		      -400000Q)
		(CKEQ (IDIFFERENCE -200000Q -200000Q)
		      0)
		(CKEQ (LOGOR -200000Q -200000Q)
		      -200000Q)
		(CKEQ (LOGAND -200000Q -200000Q)
		      -200000Q)
		(CKEQ (LOGXOR -200000Q -200000Q)
		      0)
		(CKEQ (IGREATERP -200000Q 177776Q)
		      NIL)
		(CKEQ (IPLUS -200000Q 177776Q)
		      -2)
		(CKEQ (IDIFFERENCE -200000Q 177776Q)
		      -377776Q)
		(CKEQ (LOGOR -200000Q 177776Q)
		      -2)
		(CKEQ (LOGAND -200000Q 177776Q)
		      0)
		(CKEQ (LOGXOR -200000Q 177776Q)
		      -2)
		(CKEQ (IGREATERP -200000Q -200001Q)
		      T)
		(CKEQ (IPLUS -200000Q -200001Q)
		      -400001Q)
		(CKEQ (IDIFFERENCE -200000Q -200001Q)
		      1)
		(CKEQ (LOGOR -200000Q -200001Q)
		      -1)
		(CKEQ (LOGAND -200000Q -200001Q)
		      -400000Q)
		(CKEQ (LOGXOR -200000Q -200001Q)
		      377777Q)
		(CKEQ (IGREATERP 177776Q 0)
		      T)
		(CKEQ (IPLUS 177776Q 0)
		      177776Q)
		(CKEQ (IDIFFERENCE 177776Q 0)
		      177776Q)
		(CKEQ (LOGOR 177776Q 0)
		      177776Q)
		(CKEQ (LOGAND 177776Q 0)
		      0)
		(CKEQ (LOGXOR 177776Q 0)
		      177776Q)
		(CKEQ (IGREATERP 177776Q 1)
		      T)
		(CKEQ (IPLUS 177776Q 1)
		      177777Q)
		(CKEQ (IDIFFERENCE 177776Q 1)
		      177775Q)
		(CKEQ (LOGOR 177776Q 1)
		      177777Q)
		(CKEQ (LOGAND 177776Q 1)
		      0)
		(CKEQ (LOGXOR 177776Q 1)
		      177777Q)
		(CKEQ (IGREATERP 177776Q -1)
		      T)
		(CKEQ (IPLUS 177776Q -1)
		      177775Q)
		(CKEQ (IDIFFERENCE 177776Q -1)
		      177777Q)
		(CKEQ (LOGOR 177776Q -1)
		      -1)
		(CKEQ (LOGAND 177776Q -1)
		      177776Q)
		(CKEQ (LOGXOR 177776Q -1)
		      -177777Q)
		(CKEQ (IGREATERP 177776Q 2)
		      T))))

(!NUMTEST5
  (LAMBDA NIL                                                (* bvm: " 8-MAR-82 23:00")
    (MTCHECKSTK (CKEQ (IPLUS 177776Q 2)
		      200000Q)
		(CKEQ (IDIFFERENCE 177776Q 2)
		      177774Q)
		(CKEQ (LOGOR 177776Q 2)
		      177776Q)
		(CKEQ (LOGAND 177776Q 2)
		      2)
		(CKEQ (LOGXOR 177776Q 2)
		      177774Q)
		(CKEQ (IGREATERP 177776Q -2)
		      T)
		(CKEQ (IPLUS 177776Q -2)
		      177774Q)
		(CKEQ (IDIFFERENCE 177776Q -2)
		      200000Q)
		(CKEQ (LOGOR 177776Q -2)
		      -2)
		(CKEQ (LOGAND 177776Q -2)
		      177776Q)
		(CKEQ (LOGXOR 177776Q -2)
		      -200000Q)
		(CKEQ (IGREATERP 177776Q 177777Q)
		      NIL)
		(CKEQ (IPLUS 177776Q 177777Q)
		      377775Q)
		(CKEQ (IDIFFERENCE 177776Q 177777Q)
		      -1)
		(CKEQ (LOGOR 177776Q 177777Q)
		      177777Q)
		(CKEQ (LOGAND 177776Q 177777Q)
		      177776Q)
		(CKEQ (LOGXOR 177776Q 177777Q)
		      1)
		(CKEQ (IGREATERP 177776Q -200000Q)
		      T)
		(CKEQ (IPLUS 177776Q -200000Q)
		      -2)
		(CKEQ (IDIFFERENCE 177776Q -200000Q)
		      377776Q)
		(CKEQ (LOGOR 177776Q -200000Q)
		      -2)
		(CKEQ (LOGAND 177776Q -200000Q)
		      0)
		(CKEQ (LOGXOR 177776Q -200000Q)
		      -2)
		(CKEQ (IGREATERP 177776Q 177776Q)
		      NIL)
		(CKEQ (IPLUS 177776Q 177776Q)
		      377774Q)
		(CKEQ (IDIFFERENCE 177776Q 177776Q)
		      0)
		(CKEQ (LOGOR 177776Q 177776Q)
		      177776Q)
		(CKEQ (LOGAND 177776Q 177776Q)
		      177776Q)
		(CKEQ (LOGXOR 177776Q 177776Q)
		      0)
		(CKEQ (IGREATERP 177776Q -200001Q)
		      T)
		(CKEQ (IPLUS 177776Q -200001Q)
		      -3)
		(CKEQ (IDIFFERENCE 177776Q -200001Q)
		      377777Q)
		(CKEQ (LOGOR 177776Q -200001Q)
		      -200001Q)
		(CKEQ (LOGAND 177776Q -200001Q)
		      177776Q)
		(CKEQ (LOGXOR 177776Q -200001Q)
		      -377777Q)
		(CKEQ (IGREATERP -200001Q 0)
		      NIL)
		(CKEQ (IPLUS -200001Q 0)
		      -200001Q)
		(CKEQ (IDIFFERENCE -200001Q 0)
		      -200001Q)
		(CKEQ (LOGOR -200001Q 0)
		      -200001Q)
		(CKEQ (LOGAND -200001Q 0)
		      0)
		(CKEQ (LOGXOR -200001Q 0)
		      -200001Q)
		(CKEQ (IGREATERP -200001Q 1)
		      NIL)
		(CKEQ (IPLUS -200001Q 1)
		      -200000Q)
		(CKEQ (IDIFFERENCE -200001Q 1)
		      -200002Q)
		(CKEQ (LOGOR -200001Q 1)
		      -200001Q)
		(CKEQ (LOGAND -200001Q 1)
		      1)
		(CKEQ (LOGXOR -200001Q 1)
		      -200002Q)
		(CKEQ (IGREATERP -200001Q -1)
		      NIL)
		(CKEQ (IPLUS -200001Q -1)
		      -200002Q)
		(CKEQ (IDIFFERENCE -200001Q -1)
		      -200000Q)
		(CKEQ (LOGOR -200001Q -1)
		      -1)
		(CKEQ (LOGAND -200001Q -1)
		      -200001Q)
		(CKEQ (LOGXOR -200001Q -1)
		      200000Q)
		(CKEQ (IGREATERP -200001Q 2)
		      NIL)
		(CKEQ (IPLUS -200001Q 2)
		      -177777Q)
		(CKEQ (IDIFFERENCE -200001Q 2)
		      -200003Q)
		(CKEQ (LOGOR -200001Q 2)
		      -200001Q)
		(CKEQ (LOGAND -200001Q 2)
		      2)
		(CKEQ (LOGXOR -200001Q 2)
		      -200003Q)
		(CKEQ (IGREATERP -200001Q -2)
		      NIL)
		(CKEQ (IPLUS -200001Q -2)
		      -200003Q)
		(CKEQ (IDIFFERENCE -200001Q -2)
		      -177777Q)
		(CKEQ (LOGOR -200001Q -2)
		      -1)
		(CKEQ (LOGAND -200001Q -2)
		      -200002Q)
		(CKEQ (LOGXOR -200001Q -2)
		      200001Q)
		(CKEQ (IGREATERP -200001Q 177777Q)
		      NIL)
		(CKEQ (IPLUS -200001Q 177777Q)
		      -2)
		(CKEQ (IDIFFERENCE -200001Q 177777Q)
		      -400000Q)
		(CKEQ (LOGOR -200001Q 177777Q)
		      -200001Q)
		(CKEQ (LOGAND -200001Q 177777Q)
		      177777Q)
		(CKEQ (LOGXOR -200001Q 177777Q)
		      -400000Q)
		(CKEQ (IGREATERP -200001Q -200000Q)
		      NIL)
		(CKEQ (IPLUS -200001Q -200000Q)
		      -400001Q)
		(CKEQ (IDIFFERENCE -200001Q -200000Q)
		      -1)
		(CKEQ (LOGOR -200001Q -200000Q)
		      -1)
		(CKEQ (LOGAND -200001Q -200000Q)
		      -400000Q)
		(CKEQ (LOGXOR -200001Q -200000Q)
		      377777Q)
		(CKEQ (IGREATERP -200001Q 177776Q)
		      NIL)
		(CKEQ (IPLUS -200001Q 177776Q)
		      -3)
		(CKEQ (IDIFFERENCE -200001Q 177776Q)
		      -377777Q)
		(CKEQ (LOGOR -200001Q 177776Q)
		      -200001Q)
		(CKEQ (LOGAND -200001Q 177776Q)
		      177776Q)
		(CKEQ (LOGXOR -200001Q 177776Q)
		      -377777Q)
		(CKEQ (IGREATERP -200001Q -200001Q)
		      NIL)
		(CKEQ (IPLUS -200001Q -200001Q)
		      -400002Q)
		(CKEQ (IDIFFERENCE -200001Q -200001Q)
		      0)
		(CKEQ (LOGOR -200001Q -200001Q)
		      -200001Q)
		(CKEQ (LOGAND -200001Q -200001Q)
		      -200001Q)
		(CKEQ (LOGXOR -200001Q -200001Q)
		      0)
		(CKEQ (LRSH 0 1)
		      0)
		(CKEQ (LLSH 0 1)
		      0)
		(CKEQ (LRSH 0 10Q)
		      0)
		(CKEQ (LLSH 0 10Q)
		      0)
		(CKEQ (LRSH 1 1)
		      0)
		(CKEQ (LLSH 1 1)
		      2)
		(CKEQ (LRSH 1 10Q)
		      0)
		(CKEQ (LLSH 1 10Q)
		      400Q)
		(CKEQ (LLSH -1 1)
		      -2)
		(CKEQ (LLSH -1 10Q)
		      -400Q))))

(!NUMTEST6
  (LAMBDA NIL                                                (* bvm: " 8-MAR-82 23:00")
    (MTCHECKSTK (CKEQ (LRSH 2 1)
		      1)
		(CKEQ (LLSH 2 1)
		      4)
		(CKEQ (LRSH 2 10Q)
		      0)
		(CKEQ (LLSH 2 10Q)
		      1000Q)
		(CKEQ (LLSH -2 1)
		      -4)
		(CKEQ (LLSH -2 10Q)
		      -1000Q)
		(CKEQ (LRSH 177777Q 1)
		      77777Q)
		(CKEQ (LLSH 177777Q 1)
		      377776Q)
		(CKEQ (LRSH 177777Q 10Q)
		      377Q)
		(CKEQ (LLSH 177777Q 10Q)
		      77777400Q)
		(CKEQ (LLSH -200000Q 1)
		      -400000Q)
		(CKEQ (LLSH -200000Q 10Q)
		      -100000000Q)
		(CKEQ (LRSH 177776Q 1)
		      77777Q)
		(CKEQ (LLSH 177776Q 1)
		      377774Q)
		(CKEQ (LRSH 177776Q 10Q)
		      377Q)
		(CKEQ (LLSH 177776Q 10Q)
		      77777000Q)
		(CKEQ (LLSH -200001Q 1)
		      -400002Q)
		(CKEQ (LLSH -200001Q 10Q)
		      -100000400Q)
		(CKEQ (IQUOTIENT 0 1)
		      0)
		(CKEQ (IREMAINDER 0 1)
		      0)
		(CKEQ (ITIMES 0 1)
		      0)
		(CKEQ (IQUOTIENT 0 10Q)
		      0)
		(CKEQ (IREMAINDER 0 10Q)
		      0)
		(CKEQ (ITIMES 0 10Q)
		      0)
		(CKEQ (IQUOTIENT 1 1)
		      1)
		(CKEQ (IREMAINDER 1 1)
		      0)
		(CKEQ (ITIMES 1 1)
		      1)
		(CKEQ (IQUOTIENT 1 10Q)
		      0)
		(CKEQ (IREMAINDER 1 10Q)
		      1)
		(CKEQ (ITIMES 1 10Q)
		      10Q)
		(CKEQ (IQUOTIENT -1 1)
		      -1)
		(CKEQ (IREMAINDER -1 1)
		      0)
		(CKEQ (ITIMES -1 1)
		      -1)
		(CKEQ (IQUOTIENT -1 10Q)
		      0)
		(CKEQ (IREMAINDER -1 10Q)
		      -1)
		(CKEQ (ITIMES -1 10Q)
		      -10Q)
		(CKEQ (IQUOTIENT 2 1)
		      2)
		(CKEQ (IREMAINDER 2 1)
		      0)
		(CKEQ (ITIMES 2 1)
		      2)
		(CKEQ (IQUOTIENT 2 10Q)
		      0)
		(CKEQ (IREMAINDER 2 10Q)
		      2)
		(CKEQ (ITIMES 2 10Q)
		      20Q)
		(CKEQ (IQUOTIENT -2 1)
		      -2)
		(CKEQ (IREMAINDER -2 1)
		      0)
		(CKEQ (ITIMES -2 1)
		      -2)
		(CKEQ (IQUOTIENT -2 10Q)
		      0)
		(CKEQ (IREMAINDER -2 10Q)
		      -2)
		(CKEQ (ITIMES -2 10Q)
		      -20Q)
		(CKEQ (IQUOTIENT 177777Q 1)
		      177777Q)
		(CKEQ (IREMAINDER 177777Q 1)
		      0)
		(CKEQ (ITIMES 177777Q 1)
		      177777Q)
		(CKEQ (IQUOTIENT 177777Q 10Q)
		      17777Q)
		(CKEQ (IREMAINDER 177777Q 10Q)
		      7)
		(CKEQ (ITIMES 177777Q 10Q)
		      1777770Q)
		(CKEQ (IQUOTIENT -200000Q 1)
		      -200000Q)
		(CKEQ (IREMAINDER -200000Q 1)
		      0)
		(CKEQ (ITIMES -200000Q 1)
		      -200000Q)
		(CKEQ (IQUOTIENT -200000Q 10Q)
		      -20000Q)
		(CKEQ (IREMAINDER -200000Q 10Q)
		      0)
		(CKEQ (ITIMES -200000Q 10Q)
		      -2000000Q)
		(CKEQ (IQUOTIENT 177776Q 1)
		      177776Q)
		(CKEQ (IREMAINDER 177776Q 1)
		      0)
		(CKEQ (ITIMES 177776Q 1)
		      177776Q)
		(CKEQ (IQUOTIENT 177776Q 10Q)
		      17777Q)
		(CKEQ (IREMAINDER 177776Q 10Q)
		      6)
		(CKEQ (ITIMES 177776Q 10Q)
		      1777760Q)
		(CKEQ (IQUOTIENT -200001Q 1)
		      -200001Q)
		(CKEQ (IREMAINDER -200001Q 1)
		      0)
		(CKEQ (ITIMES -200001Q 1)
		      -200001Q)
		(CKEQ (IQUOTIENT -200001Q 10Q)
		      -20000Q)
		(CKEQ (IREMAINDER -200001Q 10Q)
		      -1)
		(CKEQ (ITIMES -200001Q 10Q)
		      -2000010Q)
		(CKEQ (IQUOTIENT 3 1)
		      3)
		(CKEQ (IREMAINDER 3 1)
		      0)
		(CKEQ (ITIMES 3 1)
		      3)
		(CKEQ (IQUOTIENT 3 10Q)
		      0)
		(CKEQ (IREMAINDER 3 10Q)
		      3)
		(CKEQ (ITIMES 3 10Q)
		      30Q)
		(CKEQ (IQUOTIENT -3 1)
		      -3)
		(CKEQ (IREMAINDER -3 1)
		      0)
		(CKEQ (ITIMES -3 1)
		      -3)
		(CKEQ (IQUOTIENT -3 10Q)
		      0)
		(CKEQ (IREMAINDER -3 10Q)
		      -3)
		(CKEQ (ITIMES -3 10Q)
		      -30Q)
		(CKEQ (IQUOTIENT 4 1)
		      4)
		(CKEQ (IREMAINDER 4 1)
		      0)
		(CKEQ (ITIMES 4 1)
		      4)
		(CKEQ (IQUOTIENT 4 10Q)
		      0)
		(CKEQ (IREMAINDER 4 10Q)
		      4)
		(CKEQ (ITIMES 4 10Q)
		      40Q)
		(CKEQ (IQUOTIENT -4 1)
		      -4)
		(CKEQ (IREMAINDER -4 1)
		      0)
		(CKEQ (ITIMES -4 1)
		      -4)
		(CKEQ (IQUOTIENT -4 10Q)
		      0)
		(CKEQ (IREMAINDER -4 10Q)
		      -4)
		(CKEQ (ITIMES -4 10Q)
		      -40Q))))

(!RANDNUMTEST
  (LAMBDA NIL                                                (* lmm " 5-JAN-82 20:03")

          (* (PROG (FORMS FORM ARG1 ARG2) (FRPTQ 36Q (SETQ ARG1 (SELECTQ (RAND 0 2) (0 (RAND -200000Q 177777Q)) 
	  (1 (RAND -5 5)) (RAND -20000000000Q 17777777777Q))) (SETQ ARG2 (SELECTQ (RAND 0 2) (0 (RAND -200000Q 177777Q)) 
	  (1 (RAND -5 5)) (RAND -20000000000Q 17777777777Q))) (for FN in (QUOTE (ITIMES IQUOTIENT IPLUS IDIFFERENCE 
	  IREMAINDER)) do (COND ((OR (NEQ ARG2 0) (NEQ FN (QUOTE IQUOTIENT))) (SETQ FORM (APPLY* (PACK* 
	  (QUOTE F) (SUBATOM FN 2 -1)) (FLOAT ARG1) (FLOAT ARG2))) (COND ((AND (FGREATERP FORM -20000000000Q) 
	  (FLESSP FORM -20000000000Q)) (SETQ FORM (LIST FN ARG1 ARG2)) (push FORMS (LIST (QUOTE CKEQ) FORM 
	  (EVAL FORM))))))))) (RETURN (CONS (QUOTE MTCHECKSTK) FORMS))))


    (!RANDNUMTEST1)
    (!RANDNUMTEST2)
    (!RANDNUMTEST3)
    (!RANDNUMTEST4)))

(!RANDNUMTEST1
  (LAMBDA NIL                                                (* lmm " 5-JAN-82 20:00")
    (MTCHECKSTK (CKEQ (IDIFFERENCE 225103021Q -41354Q)
		      225144375Q)
		(CKEQ (IPLUS 225103021Q -41354Q)
		      225041445Q)
		(CKEQ (IQUOTIENT 225103021Q -41354Q)
		      -4351Q)
		(CKEQ (IDIFFERENCE 55211Q -170231Q)
		      245442Q)
		(CKEQ (IPLUS 55211Q -170231Q)
		      -113020Q)
		(CKEQ (IQUOTIENT 55211Q -170231Q)
		      0)
		(CKEQ (ITIMES 55211Q -170231Q)
		      -12505505741Q)
		(CKEQ (IDIFFERENCE 7527556636Q 6230151670Q)
		      1277404746Q)
		(CKEQ (IPLUS 7527556636Q 6230151670Q)
		      15757730526Q)
		(CKEQ (IQUOTIENT 7527556636Q 6230151670Q)
		      1)
		(CKEQ (IDIFFERENCE 46753Q 147206Q)
		      -100233Q)
		(CKEQ (IPLUS 46753Q 147206Q)
		      216161Q)
		(CKEQ (IQUOTIENT 46753Q 147206Q)
		      0)
		(CKEQ (ITIMES 46753Q 147206Q)
		      7666761402Q)
		(CKEQ (IDIFFERENCE -2102475710Q 2301345735Q)
		      -4404043645Q)
		(CKEQ (IPLUS -2102475710Q 2301345735Q)
		      176650025Q)
		(CKEQ (IQUOTIENT -2102475710Q 2301345735Q)
		      0)
		(CKEQ (IDIFFERENCE -2623Q 4352565011Q)
		      -4352567634Q)
		(CKEQ (IPLUS -2623Q 4352565011Q)
		      4352562166Q)
		(CKEQ (IQUOTIENT -2623Q 4352565011Q)
		      0)
		(CKEQ (IDIFFERENCE -14153253501Q -57651Q)
		      -14153173630Q)
		(CKEQ (IPLUS -14153253501Q -57651Q)
		      -14153333352Q)
		(CKEQ (IQUOTIENT -14153253501Q -57651Q)
		      202545Q)
		(CKEQ (IDIFFERENCE 165526Q 2720657437Q)
		      -2720471711Q)
		(CKEQ (IPLUS 165526Q 2720657437Q)
		      2721045165Q)
		(CKEQ (IQUOTIENT 165526Q 2720657437Q)
		      0)
		(CKEQ (IDIFFERENCE 2225143040Q 64675Q)
		      2225056143Q)
		(CKEQ (IPLUS 2225143040Q 64675Q)
		      2225227735Q)
		(CKEQ (IQUOTIENT 2225143040Q 64675Q)
		      26141Q)
		(CKEQ (IPLUS -12315334401Q 14120673261Q)
		      1603336660Q)
		(CKEQ (IQUOTIENT -12315334401Q 14120673261Q)
		      0)
		(CKEQ (IDIFFERENCE -10505775255Q 163226Q)
		      -10506160503Q)
		(CKEQ (IPLUS -10505775255Q 163226Q)
		      -10505612027Q)
		(CKEQ (IQUOTIENT -10505775255Q 163226Q)
		      -46265Q)
		(CKEQ (IDIFFERENCE 122271Q 173021Q)
		      -50530Q)
		(CKEQ (IPLUS 122271Q 173021Q)
		      315312Q)
		(CKEQ (IQUOTIENT 122271Q 173021Q)
		      0)
		(CKEQ (IDIFFERENCE 16047667244Q -135273Q)
		      16050024537Q)
		(CKEQ (IPLUS 16047667244Q -135273Q)
		      16047531751Q)
		(CKEQ (IQUOTIENT 16047667244Q -135273Q)
		      -115146Q)
		(CKEQ (IDIFFERENCE -16411515370Q 21036Q)
		      -16411536426Q)
		(CKEQ (IPLUS -16411515370Q 21036Q)
		      -16411474332Q)
		(CKEQ (IQUOTIENT -16411515370Q 21036Q)
		      -663613Q)
		(CKEQ (IDIFFERENCE -11057170232Q -34634Q)
		      -11057133376Q)
		(CKEQ (IPLUS -11057170232Q -34634Q)
		      -11057225066Q)
		(CKEQ (IQUOTIENT -11057170232Q -34634Q)
		      241472Q)
		(CKEQ (IPLUS 14517530732Q -6065652751Q)
		      6431655761Q)
		(CKEQ (IQUOTIENT 14517530732Q -6065652751Q)
		      -2)
		(CKEQ (IDIFFERENCE 137044Q -4034725370Q)
		      4035064434Q)
		(CKEQ (IPLUS 137044Q -4034725370Q)
		      -4034566324Q)
		(CKEQ (IQUOTIENT 137044Q -4034725370Q)
		      0)
		(CKEQ (IDIFFERENCE -14543070643Q -1302005044Q)
		      -13241063577Q)
		(CKEQ (IPLUS -14543070643Q -1302005044Q)
		      -16045075707Q)
		(CKEQ (IQUOTIENT -14543070643Q -1302005044Q)
		      11Q)
		(CKEQ (IDIFFERENCE 14210657030Q 16531056111Q)
		      -2320177061Q)
		(CKEQ (IQUOTIENT 14210657030Q 16531056111Q)
		      0)
		(CKEQ (IDIFFERENCE 550212747Q 1055626226Q)
		      -305413257Q)
		(CKEQ (IPLUS 550212747Q 1055626226Q)
		      1626041175Q)
		(CKEQ (IQUOTIENT 550212747Q 1055626226Q)
		      0)
		(CKEQ (IDIFFERENCE -11131703146Q -11764360741Q)
		      632455573Q)
		(CKEQ (IQUOTIENT -11131703146Q -11764360741Q)
		      0)
		(CKEQ (IDIFFERENCE 1541425342Q 12472345535Q)
		      -10730720173Q)
		(CKEQ (IPLUS 1541425342Q 12472345535Q)
		      14233773077Q)
		(CKEQ (IQUOTIENT 1541425342Q 12472345535Q)
		      0)
		(CKEQ (IDIFFERENCE -15531366430Q -100526Q)
		      -15531265702Q)
		(CKEQ (IPLUS -15531366430Q -100526Q)
		      -15531467156Q)
		(CKEQ (IQUOTIENT -15531366430Q -100526Q)
		      154211Q)
		(CKEQ (IDIFFERENCE -41050Q -326400641Q)
		      326337571Q)
		(CKEQ (IPLUS -41050Q -326400641Q)
		      -326441711Q)
		(CKEQ (IQUOTIENT -41050Q -326400641Q)
		      0)
		(CKEQ (IPLUS 16630056316Q -13347047476Q)
		      3261006620Q)
		(CKEQ (IQUOTIENT 16630056316Q -13347047476Q)
		      -1)
		(CKEQ (IDIFFERENCE -31740Q -6001042052Q)
		      6001010112Q)
		(CKEQ (IPLUS -31740Q -6001042052Q)
		      -6001074012Q)
		(CKEQ (IQUOTIENT -31740Q -6001042052Q)
		      0)
		(CKEQ (IDIFFERENCE -110217Q -12653617250Q)
		      12653507031Q)
		(CKEQ (IPLUS -110217Q -12653617250Q)
		      -12653727467Q)
		(CKEQ (IQUOTIENT -110217Q -12653617250Q)
		      0)
		(CKEQ (IDIFFERENCE 116216Q 2453154032Q)
		      -2453035614Q)
		(CKEQ (IPLUS 116216Q 2453154032Q)
		      2453272250Q)
		(CKEQ (IQUOTIENT 116216Q 2453154032Q)
		      0)
		(CKEQ (IDIFFERENCE 4553332136Q -4142306347Q)
		      10715640505Q)
		(CKEQ (IPLUS 4553332136Q -4142306347Q)
		      411023567Q)
		(CKEQ (IQUOTIENT 4553332136Q -4142306347Q)
		      -1)
		(CKEQ (IPLUS 17161754144Q -3270231756Q)
		      13671522166Q)
		(CKEQ (IQUOTIENT 17161754144Q -3270231756Q)
		      -4))))

(!RANDNUMTEST2
  (LAMBDA NIL                                                (* lmm " 5-JAN-82 20:01")
    (MTCHECKSTK (CKEQ (IREMAINDER 7372147664Q -161456Q)
		      64130Q)
		(CKEQ (IDIFFERENCE 7372147664Q -161456Q)
		      7372331342Q)
		(CKEQ (IPLUS 7372147664Q -161456Q)
		      7371766206Q)
		(CKEQ (IQUOTIENT 7372147664Q -161456Q)
		      -41602Q)
		(CKEQ (IREMAINDER 17634621231Q -146562Q)
		      124171Q)
		(CKEQ (IDIFFERENCE 17634621231Q -146562Q)
		      17634770013Q)
		(CKEQ (IPLUS 17634621231Q -146562Q)
		      17634452447Q)
		(CKEQ (IQUOTIENT 17634621231Q -146562Q)
		      -116620Q)
		(CKEQ (IREMAINDER -117002Q 11327523020Q)
		      -117002Q)
		(CKEQ (IDIFFERENCE -117002Q 11327523020Q)
		      -11327642022Q)
		(CKEQ (IPLUS -117002Q 11327523020Q)
		      11327404016Q)
		(CKEQ (IQUOTIENT -117002Q 11327523020Q)
		      0)
		(CKEQ (IREMAINDER 7040503561Q 5360767723Q)
		      1457513636Q)
		(CKEQ (IDIFFERENCE 7040503561Q 5360767723Q)
		      1457513636Q)
		(CKEQ (IPLUS 7040503561Q 5360767723Q)
		      14421473504Q)
		(CKEQ (IQUOTIENT 7040503561Q 5360767723Q)
		      1)
		(CKEQ (IREMAINDER 2701423332Q -17633736657Q)
		      2701423332Q)
		(CKEQ (IPLUS 2701423332Q -17633736657Q)
		      -14732313325Q)
		(CKEQ (IQUOTIENT 2701423332Q -17633736657Q)
		      0)
		(CKEQ (IREMAINDER -15075426141Q 53650Q)
		      -15721Q)
		(CKEQ (IDIFFERENCE -15075426141Q 53650Q)
		      -15075502011Q)
		(CKEQ (IPLUS -15075426141Q 53650Q)
		      -15075352271Q)
		(CKEQ (IQUOTIENT -15075426141Q 53650Q)
		      -231212Q)
		(CKEQ (IREMAINDER 11564140373Q 5167Q)
		      3101Q)
		(CKEQ (IDIFFERENCE 11564140373Q 5167Q)
		      11564133204Q)
		(CKEQ (IPLUS 11564140373Q 5167Q)
		      11564145562Q)
		(CKEQ (IQUOTIENT 11564140373Q 5167Q)
		      1667626Q)
		(CKEQ (IREMAINDER -766157106Q 11221047643Q)
		      -766157106Q)
		(CKEQ (IDIFFERENCE -766157106Q 11221047643Q)
		      -12207226751Q)
		(CKEQ (IPLUS -766157106Q 11221047643Q)
		      10232670535Q)
		(CKEQ (IQUOTIENT -766157106Q 11221047643Q)
		      0)
		(CKEQ (IREMAINDER -134743Q -10243Q)
		      -1342Q)
		(CKEQ (IDIFFERENCE -134743Q -10243Q)
		      -124500Q)
		(CKEQ (IPLUS -134743Q -10243Q)
		      -145206Q)
		(CKEQ (IQUOTIENT -134743Q -10243Q)
		      13Q)
		(CKEQ (ITIMES -134743Q -10243Q)
		      1405105611Q)
		(CKEQ (IREMAINDER 156361Q 44021Q)
		      2276Q)
		(CKEQ (IDIFFERENCE 156361Q 44021Q)
		      112340Q)
		(CKEQ (IPLUS 156361Q 44021Q)
		      222402Q)
		(CKEQ (IQUOTIENT 156361Q 44021Q)
		      3)
		(CKEQ (ITIMES 156361Q 44021Q)
		      7614472001Q)
		(CKEQ (IREMAINDER -7606212052Q -12463650767Q)
		      -7606212052Q)
		(CKEQ (IDIFFERENCE -7606212052Q -12463650767Q)
		      2655436715Q)
		(CKEQ (IQUOTIENT -7606212052Q -12463650767Q)
		      0)
		(CKEQ (IREMAINDER -23644Q 2024103014Q)
		      -23644Q)
		(CKEQ (IDIFFERENCE -23644Q 2024103014Q)
		      -2024126660Q)
		(CKEQ (IPLUS -23644Q 2024103014Q)
		      2024057150Q)
		(CKEQ (IQUOTIENT -23644Q 2024103014Q)
		      0)
		(CKEQ (IREMAINDER 142402Q -11771213026Q)
		      142402Q)
		(CKEQ (IDIFFERENCE 142402Q -11771213026Q)
		      11771355430Q)
		(CKEQ (IPLUS 142402Q -11771213026Q)
		      -11771050424Q)
		(CKEQ (IQUOTIENT 142402Q -11771213026Q)
		      0)
		(CKEQ (IREMAINDER 137211Q 123321Q)
		      13670Q)
		(CKEQ (IDIFFERENCE 137211Q 123321Q)
		      13670Q)
		(CKEQ (IPLUS 137211Q 123321Q)
		      262532Q)
		(CKEQ (IQUOTIENT 137211Q 123321Q)
		      1)
		(CKEQ (ITIMES 137211Q 123321Q)
		      17412061731Q)
		(CKEQ (IREMAINDER -203262767Q 163647Q)
		      -107633Q)
		(CKEQ (IDIFFERENCE -203262767Q 163647Q)
		      -203446636Q)
		(CKEQ (IPLUS -203262767Q 163647Q)
		      -203077120Q)
		(CKEQ (IQUOTIENT -203262767Q 163647Q)
		      -1104Q)
		(CKEQ (IREMAINDER -6313474405Q 6752273462Q)
		      -6313474405Q)
		(CKEQ (IDIFFERENCE -6313474405Q 6752273462Q)
		      -15265770067Q)
		(CKEQ (IPLUS -6313474405Q 6752273462Q)
		      436577055Q)
		(CKEQ (IQUOTIENT -6313474405Q 6752273462Q)
		      0)
		(CKEQ (IREMAINDER -14063014353Q 113451Q)
		      -72715Q)
		(CKEQ (IDIFFERENCE -14063014353Q 113451Q)
		      -14063130024Q)
		(CKEQ (IPLUS -14063014353Q 113451Q)
		      -14062700702Q)
		(CKEQ (IQUOTIENT -14063014353Q 113451Q)
		      -121756Q)
		(CKEQ (IREMAINDER 10227145055Q 6462363731Q)
		      1544561124Q)
		(CKEQ (IDIFFERENCE 10227145055Q 6462363731Q)
		      1544561124Q)
		(CKEQ (IPLUS 10227145055Q 6462363731Q)
		      16711531006Q)
		(CKEQ (IQUOTIENT 10227145055Q 6462363731Q)
		      1)
		(CKEQ (IREMAINDER -75324Q 175652Q)
		      -75324Q)
		(CKEQ (IDIFFERENCE -75324Q 175652Q)
		      -273176Q)
		(CKEQ (IPLUS -75324Q 175652Q)
		      100326Q)
		(CKEQ (IQUOTIENT -75324Q 175652Q)
		      0)
		(CKEQ (ITIMES -75324Q 175652Q)
		      -17057666310Q)
		(CKEQ (IREMAINDER 115610Q 11164020356Q)
		      115610Q)
		(CKEQ (IDIFFERENCE 115610Q 11164020356Q)
		      -11163702546Q)
		(CKEQ (IPLUS 115610Q 11164020356Q)
		      11164136166Q)
		(CKEQ (IQUOTIENT 115610Q 11164020356Q)
		      0)
		(CKEQ (IREMAINDER -31121Q 161167Q)
		      -31121Q)
		(CKEQ (IDIFFERENCE -31121Q 161167Q)
		      -212310Q)
		(CKEQ (IPLUS -31121Q 161167Q)
		      130046Q)
		(CKEQ (IQUOTIENT -31121Q 161167Q)
		      0)
		(CKEQ (ITIMES -31121Q 161167Q)
		      -5440562647Q)
		(CKEQ (IREMAINDER -1077046130Q 2302031512Q)
		      -1077046130Q)
		(CKEQ (IDIFFERENCE -1077046130Q 2302031512Q)
		      -3401077642Q)
		(CKEQ (IPLUS -1077046130Q 2302031512Q)
		      1202763362Q)
		(CKEQ (IQUOTIENT -1077046130Q 2302031512Q)
		      0)
		(CKEQ (IREMAINDER 162464Q 5724142525Q)
		      162464Q)
		(CKEQ (IDIFFERENCE 162464Q 5724142525Q)
		      -5723760041Q)
		(CKEQ (IPLUS 162464Q 5724142525Q)
		      5724325211Q)
		(CKEQ (IQUOTIENT 162464Q 5724142525Q)
		      0)
		(CKEQ (IREMAINDER -16247235274Q 2154207235Q)
		      -1035561416Q)
		(CKEQ (IPLUS -16247235274Q 2154207235Q)
		      -14073026037Q)
		(CKEQ (IQUOTIENT -16247235274Q 2154207235Q)
		      -6)
		(CKEQ (IREMAINDER -2773332645Q 145350Q)
		      -75045Q)
		(CKEQ (IDIFFERENCE -2773332645Q 145350Q)
		      -2773500215Q)
		(CKEQ (IPLUS -2773332645Q 145350Q)
		      -2773165275Q)
		(CKEQ (IQUOTIENT -2773332645Q 145350Q)
		      -17060Q)
		(CKEQ (IREMAINDER -30761Q -26031Q)
		      -2730Q)
		(CKEQ (IDIFFERENCE -30761Q -26031Q)
		      -2730Q)
		(CKEQ (IPLUS -30761Q -26031Q)
		      -57012Q)
		(CKEQ (IQUOTIENT -30761Q -26031Q)
		      1)
		(CKEQ (ITIMES -30761Q -26031Q)
		      1046446211Q)
		(CKEQ (IREMAINDER -70373Q -115660Q)
		      -70373Q)
		(CKEQ (IDIFFERENCE -70373Q -115660Q)
		      25265Q)
		(CKEQ (IPLUS -70373Q -115660Q)
		      -206253Q)
		(CKEQ (IQUOTIENT -70373Q -115660Q)
		      0)
		(CKEQ (ITIMES -70373Q -115660Q)
		      10455322620Q)
		(CKEQ (IREMAINDER -161501Q -106613Q)
		      -52666Q)
		(CKEQ (IDIFFERENCE -161501Q -106613Q)
		      -52666Q)
		(CKEQ (IPLUS -161501Q -106613Q)
		      -270314Q)
		(CKEQ (IQUOTIENT -161501Q -106613Q)
		      1)
		(CKEQ (ITIMES -161501Q -106613Q)
		      17551430513Q)
		(CKEQ (IREMAINDER -37733Q 6613741611Q)
		      -37733Q)
		(CKEQ (IDIFFERENCE -37733Q 6613741611Q)
		      -6614001544Q)
		(CKEQ (IPLUS -37733Q 6613741611Q)
		      6613701656Q)
		(CKEQ (IQUOTIENT -37733Q 6613741611Q)
		      0)
		(CKEQ (IREMAINDER 5403313261Q 170515Q)
		      106045Q)
		(CKEQ (IDIFFERENCE 5403313261Q 170515Q)
		      5403122544Q)
		(CKEQ (IPLUS 5403313261Q 170515Q)
		      5403503776Q)
		(CKEQ (IQUOTIENT 5403313261Q 170515Q)
		      27274Q))))

(!RANDNUMTEST3
  (LAMBDA NIL                                                (* lmm " 5-JAN-82 20:02")
    (MTCHECKSTK (CKEQ (IREMAINDER 7362115002Q 33052Q)
		      12214Q)
		(CKEQ (IDIFFERENCE 7362115002Q 33052Q)
		      7362061730Q)
		(CKEQ (IPLUS 7362115002Q 33052Q)
		      7362150054Q)
		(CKEQ (IQUOTIENT 7362115002Q 33052Q)
		      215217Q)
		(CKEQ (IREMAINDER 156125Q -77040Q)
		      57065Q)
		(CKEQ (IDIFFERENCE 156125Q -77040Q)
		      255165Q)
		(CKEQ (IPLUS 156125Q -77040Q)
		      57065Q)
		(CKEQ (IQUOTIENT 156125Q -77040Q)
		      -1)
		(CKEQ (ITIMES 156125Q -77040Q)
		      -15443260240Q)
		(CKEQ (IREMAINDER 17144576471Q 63524Q)
		      36051Q)
		(CKEQ (IDIFFERENCE 17144576471Q 63524Q)
		      17144512745Q)
		(CKEQ (IPLUS 17144576471Q 63524Q)
		      17144662215Q)
		(CKEQ (IQUOTIENT 17144576471Q 63524Q)
		      226464Q)
		(CKEQ (IREMAINDER -1004475702Q -3747655621Q)
		      -1004475702Q)
		(CKEQ (IDIFFERENCE -1004475702Q -3747655621Q)
		      2743157717Q)
		(CKEQ (IPLUS -1004475702Q -3747655621Q)
		      -4754353523Q)
		(CKEQ (IQUOTIENT -1004475702Q -3747655621Q)
		      0)
		(CKEQ (IREMAINDER 7154Q 74266Q)
		      7154Q)
		(CKEQ (IDIFFERENCE 7154Q 74266Q)
		      -65112Q)
		(CKEQ (IPLUS 7154Q 74266Q)
		      103442Q)
		(CKEQ (IQUOTIENT 7154Q 74266Q)
		      0)
		(CKEQ (ITIMES 7154Q 74266Q)
		      663160310Q)
		(CKEQ (IREMAINDER 14551535630Q -16006147276Q)
		      14551535630Q)
		(CKEQ (IPLUS 14551535630Q -16006147276Q)
		      -1234411446Q)
		(CKEQ (IQUOTIENT 14551535630Q -16006147276Q)
		      0)
		(CKEQ (IREMAINDER -7700724341Q -13323635271Q)
		      -7700724341Q)
		(CKEQ (IDIFFERENCE -7700724341Q -13323635271Q)
		      3422710730Q)
		(CKEQ (IQUOTIENT -7700724341Q -13323635271Q)
		      0)
		(CKEQ (IREMAINDER -130016Q -37545Q)
		      -30504Q)
		(CKEQ (IDIFFERENCE -130016Q -37545Q)
		      -70251Q)
		(CKEQ (IPLUS -130016Q -37545Q)
		      -167563Q)
		(CKEQ (IQUOTIENT -130016Q -37545Q)
		      2)
		(CKEQ (ITIMES -130016Q -37545Q)
		      5346163606Q)
		(CKEQ (IREMAINDER 145065Q 142234Q)
		      2631Q)
		(CKEQ (IDIFFERENCE 145065Q 142234Q)
		      2631Q)
		(CKEQ (IPLUS 145065Q 142234Q)
		      307321Q)
		(CKEQ (IQUOTIENT 145065Q 142234Q)
		      1)
		(CKEQ (IREMAINDER -114603Q 54774426Q)
		      -114603Q)
		(CKEQ (IDIFFERENCE -114603Q 54774426Q)
		      -55111231Q)
		(CKEQ (IPLUS -114603Q 54774426Q)
		      54657623Q)
		(CKEQ (IQUOTIENT -114603Q 54774426Q)
		      0)
		(CKEQ (IREMAINDER 12673322761Q -11447432721Q)
		      1223670040Q)
		(CKEQ (IPLUS 12673322761Q -11447432721Q)
		      1223670040Q)
		(CKEQ (IQUOTIENT 12673322761Q -11447432721Q)
		      -1)
		(CKEQ (IREMAINDER -173542Q -65615Q)
		      -20110Q)
		(CKEQ (IDIFFERENCE -173542Q -65615Q)
		      -105725Q)
		(CKEQ (IPLUS -173542Q -65615Q)
		      -261357Q)
		(CKEQ (IQUOTIENT -173542Q -65615Q)
		      2)
		(CKEQ (ITIMES -173542Q -65615Q)
		      14773433372Q)
		(CKEQ (IREMAINDER 104500Q 12532705726Q)
		      104500Q)
		(CKEQ (IDIFFERENCE 104500Q 12532705726Q)
		      -12532601226Q)
		(CKEQ (IPLUS 104500Q 12532705726Q)
		      12533012426Q)
		(CKEQ (IQUOTIENT 104500Q 12532705726Q)
		      0)
		(CKEQ (IREMAINDER 70447Q -45711Q)
		      22536Q)
		(CKEQ (IDIFFERENCE 70447Q -45711Q)
		      136360Q)
		(CKEQ (IPLUS 70447Q -45711Q)
		      22536Q)
		(CKEQ (IQUOTIENT 70447Q -45711Q)
		      -1)
		(CKEQ (ITIMES 70447Q -45711Q)
		      -4137642237Q)
		(CKEQ (IREMAINDER 157014Q 6410506327Q)
		      157014Q)
		(CKEQ (IDIFFERENCE 157014Q 6410506327Q)
		      -6410327313Q)
		(CKEQ (IPLUS 157014Q 6410506327Q)
		      6410665343Q)
		(CKEQ (IQUOTIENT 157014Q 6410506327Q)
		      0)
		(CKEQ (IREMAINDER -5531662541Q 33210Q)
		      -22461Q)
		(CKEQ (IDIFFERENCE -5531662541Q 33210Q)
		      -5531715751Q)
		(CKEQ (IPLUS -5531662541Q 33210Q)
		      -5531627331Q)
		(CKEQ (IQUOTIENT -5531662541Q 33210Q)
		      -152446Q)
		(CKEQ (IREMAINDER -757266226Q -155715Q)
		      -122057Q)
		(CKEQ (IDIFFERENCE -757266226Q -155715Q)
		      -757110311Q)
		(CKEQ (IPLUS -757266226Q -155715Q)
		      -757444143Q)
		(CKEQ (IQUOTIENT -757266226Q -155715Q)
		      4403Q)
		(CKEQ (IREMAINDER 12561101665Q 6715622627Q)
		      3643257036Q)
		(CKEQ (IDIFFERENCE 12561101665Q 6715622627Q)
		      3643257036Q)
		(CKEQ (IQUOTIENT 12561101665Q 6715622627Q)
		      1)
		(CKEQ (IREMAINDER 36575Q -146507Q)
		      36575Q)
		(CKEQ (IDIFFERENCE 36575Q -146507Q)
		      205304Q)
		(CKEQ (IPLUS 36575Q -146507Q)
		      -107712Q)
		(CKEQ (IQUOTIENT 36575Q -146507Q)
		      0)
		(CKEQ (ITIMES 36575Q -146507Q)
		      -6123423253Q)
		(CKEQ (IREMAINDER 43155Q 125453Q)
		      43155Q)
		(CKEQ (IDIFFERENCE 43155Q 125453Q)
		      -62276Q)
		(CKEQ (IPLUS 43155Q 125453Q)
		      170630Q)
		(CKEQ (IQUOTIENT 43155Q 125453Q)
		      0)
		(CKEQ (ITIMES 43155Q 125453Q)
		      5705521517Q)
		(CKEQ (IREMAINDER -13215101247Q 3476554023Q)
		      -320775156Q)
		(CKEQ (IDIFFERENCE -13215101247Q 3476554023Q)
		      -16713655272Q)
		(CKEQ (IPLUS -13215101247Q 3476554023Q)
		      -7516325224Q)
		(CKEQ (IQUOTIENT -13215101247Q 3476554023Q)
		      -3)
		(CKEQ (IREMAINDER 163010Q 13235743316Q)
		      163010Q)
		(CKEQ (IDIFFERENCE 163010Q 13235743316Q)
		      -13235560306Q)
		(CKEQ (IPLUS 163010Q 13235743316Q)
		      13236126326Q)
		(CKEQ (IQUOTIENT 163010Q 13235743316Q)
		      0)
		(CKEQ (IREMAINDER 13003244144Q -173327Q)
		      140535Q)
		(CKEQ (IDIFFERENCE 13003244144Q -173327Q)
		      13003437473Q)
		(CKEQ (IPLUS 13003244144Q -173327Q)
		      13003050615Q)
		(CKEQ (IQUOTIENT 13003244144Q -173327Q)
		      -55521Q)
		(CKEQ (IREMAINDER -46215Q 12704061362Q)
		      -46215Q)
		(CKEQ (IDIFFERENCE -46215Q 12704061362Q)
		      -12704127577Q)
		(CKEQ (IPLUS -46215Q 12704061362Q)
		      12704013145Q)
		(CKEQ (IQUOTIENT -46215Q 12704061362Q)
		      0)
		(CKEQ (IREMAINDER -2241Q -4264546202Q)
		      -2241Q)
		(CKEQ (IDIFFERENCE -2241Q -4264546202Q)
		      4264543741Q)
		(CKEQ (IPLUS -2241Q -4264546202Q)
		      -4264550443Q)
		(CKEQ (IQUOTIENT -2241Q -4264546202Q)
		      0)
		(CKEQ (IREMAINDER -20207Q 17333457066Q)
		      -20207Q)
		(CKEQ (IDIFFERENCE -20207Q 17333457066Q)
		      -17333477275Q)
		(CKEQ (IPLUS -20207Q 17333457066Q)
		      17333436657Q)
		(CKEQ (IQUOTIENT -20207Q 17333457066Q)
		      0)
		(CKEQ (IREMAINDER -6472607512Q 3122034574Q)
		      -226516122Q)
		(CKEQ (IDIFFERENCE -6472607512Q 3122034574Q)
		      -11614644306Q)
		(CKEQ (IPLUS -6472607512Q 3122034574Q)
		      -3350552716Q)
		(CKEQ (IQUOTIENT -6472607512Q 3122034574Q)
		      -2)
		(CKEQ (IREMAINDER -157453Q 15475670672Q)
		      -157453Q)
		(CKEQ (IDIFFERENCE -157453Q 15475670672Q)
		      -15476050345Q)
		(CKEQ (IPLUS -157453Q 15475670672Q)
		      15475511217Q)
		(CKEQ (IQUOTIENT -157453Q 15475670672Q)
		      0)
		(CKEQ (IREMAINDER -102550Q 5520722570Q)
		      -102550Q)
		(CKEQ (IDIFFERENCE -102550Q 5520722570Q)
		      -5521025340Q)
		(CKEQ (IPLUS -102550Q 5520722570Q)
		      5520620020Q)
		(CKEQ (IQUOTIENT -102550Q 5520722570Q)
		      0)
		(CKEQ (IREMAINDER 115632Q -13773705461Q)
		      115632Q)
		(CKEQ (IDIFFERENCE 115632Q -13773705461Q)
		      13774023313Q)
		(CKEQ (IPLUS 115632Q -13773705461Q)
		      -13773567627Q)
		(CKEQ (IQUOTIENT 115632Q -13773705461Q)
		      0))))

(!RANDNUMTEST4
  (LAMBDA NIL                                                (* lmm "19-Jul-84 18:02")
    (MTCHECKSTK (CKEQ (IREMAINDER 46416Q 73661Q)
		      46416Q)
		(CKEQ (IDIFFERENCE 46416Q 73661Q)
		      -25243Q)
		(CKEQ (IPLUS 46416Q 73661Q)
		      142277Q)
		(CKEQ (IQUOTIENT 46416Q 73661Q)
		      0)
		(CKEQ (ITIMES 46416Q 73661Q)
		      4401544256Q)
		(CKEQ (IREMAINDER -165357Q -15133072242Q)
		      -165357Q)
		(CKEQ (IDIFFERENCE -165357Q -15133072242Q)
		      15132704663Q)
		(CKEQ (IPLUS -165357Q -15133072242Q)
		      -15133257621Q)
		(CKEQ (IQUOTIENT -165357Q -15133072242Q)
		      0)
		(CKEQ (IREMAINDER -4052Q 622430174Q)
		      -4052Q)
		(CKEQ (IDIFFERENCE -4052Q 622430174Q)
		      -622434246Q)
		(CKEQ (IPLUS -4052Q 622430174Q)
		      622424122Q)
		(CKEQ (IQUOTIENT -4052Q 622430174Q)
		      0)
		(CKEQ (IREMAINDER -10566613407Q 6004741132Q)
		      -2561652255Q)
		(CKEQ (IDIFFERENCE -10566613407Q 6004741132Q)
		      -16573554541Q)
		(CKEQ (IPLUS -10566613407Q 6004741132Q)
		      -2561652255Q)
		(CKEQ (IQUOTIENT -10566613407Q 6004741132Q)
		      -1)
		(CKEQ (IREMAINDER -2 -4)
		      -2)
		(CKEQ (IDIFFERENCE -2 -4)
		      2)
		(CKEQ (IPLUS -2 -4)
		      -6)
		(CKEQ (IQUOTIENT -2 -4)
		      0)
		(CKEQ (ITIMES -2 -4)
		      10Q)
		(CKEQ (IREMAINDER 162662613Q -6300165562Q)
		      162662613Q)
		(CKEQ (IDIFFERENCE 162662613Q -6300165562Q)
		      6463050375Q)
		(CKEQ (IPLUS 162662613Q -6300165562Q)
		      -6115302747Q)
		(CKEQ (IQUOTIENT 162662613Q -6300165562Q)
		      0)
		(CKEQ (IREMAINDER -2 3)
		      -2)
		(CKEQ (IDIFFERENCE -2 3)
		      -5)
		(CKEQ (IPLUS -2 3)
		      1)
		(CKEQ (IQUOTIENT -2 3)
		      0)
		(CKEQ (ITIMES -2 3)
		      -6)
		(CKEQ (IREMAINDER -16047Q -171315Q)
		      -16047Q)
		(CKEQ (IDIFFERENCE -16047Q -171315Q)
		      153246Q)
		(CKEQ (IPLUS -16047Q -171315Q)
		      -207364Q)
		(CKEQ (IQUOTIENT -16047Q -171315Q)
		      0)
		(CKEQ (ITIMES -16047Q -171315Q)
		      3254664473Q)
		(CKEQ (IPLUS -4510035224Q 0)
		      -4510035224Q)
		(CKEQ (ITIMES -4510035224Q 0)
		      0)
		(CKEQ (IREMAINDER 4 167331711Q)
		      4)
		(CKEQ (IDIFFERENCE 4 167331711Q)
		      -167331705Q)
		(CKEQ (IPLUS 4 167331711Q)
		      167331715Q)
		(CKEQ (IQUOTIENT 4 167331711Q)
		      0)
		(CKEQ (ITIMES 4 167331711Q)
		      735547444Q)
		(CKEQ (IREMAINDER 10175626173Q -15244050032Q)
		      10175626173Q)
		(CKEQ (IPLUS 10175626173Q -15244050032Q)
		      -5046221637Q)
		(CKEQ (IQUOTIENT 10175626173Q -15244050032Q)
		      0)
		(CKEQ (IREMAINDER -1771422055Q 16116655424Q)
		      -1771422055Q)
		(CKEQ (IPLUS -1771422055Q 16116655424Q)
		      14125233347Q)
		(CKEQ (IQUOTIENT -1771422055Q 16116655424Q)
		      0)
		(CKEQ (IREMAINDER -5 -2)
		      -1)
		(CKEQ (IDIFFERENCE -5 -2)
		      -3)
		(CKEQ (IPLUS -5 -2)
		      -7)
		(CKEQ (IQUOTIENT -5 -2)
		      2)
		(CKEQ (ITIMES -5 -2)
		      12Q)
		(CKEQ (IREMAINDER -13001Q -125515Q)
		      -13001Q)
		(CKEQ (IDIFFERENCE -13001Q -125515Q)
		      112514Q)
		(CKEQ (IPLUS -13001Q -125515Q)
		      -140516Q)
		(CKEQ (IQUOTIENT -13001Q -125515Q)
		      0)
		(CKEQ (ITIMES -13001Q -125515Q)
		      1656244515Q)
		(CKEQ (IREMAINDER -166401Q -7027Q)
		      -5621Q)
		(CKEQ (IDIFFERENCE -166401Q -7027Q)
		      -157352Q)
		(CKEQ (IPLUS -166401Q -7027Q)
		      -175430Q)
		(CKEQ (IQUOTIENT -166401Q -7027Q)
		      20Q)
		(CKEQ (ITIMES -166401Q -7027Q)
		      1502654427Q)
		(CKEQ (IREMAINDER 4257756512Q -127717Q)
		      56223Q)
		(CKEQ (IDIFFERENCE 4257756512Q -127717Q)
		      4260106431Q)
		(CKEQ (IPLUS 4257756512Q -127717Q)
		      4257626573Q)
		(CKEQ (IQUOTIENT 4257756512Q -127717Q)
		      -31231Q)
		(CKEQ (IREMAINDER 4 -5)
		      4)
		(CKEQ (IDIFFERENCE 4 -5)
		      11Q)
		(CKEQ (IPLUS 4 -5)
		      -1)
		(CKEQ (IQUOTIENT 4 -5)
		      0)
		(CKEQ (ITIMES 4 -5)
		      -24Q)
		(CKEQ (IREMAINDER 146317Q 5230002636Q)
		      146317Q)
		(CKEQ (IDIFFERENCE 146317Q 5230002636Q)
		      -5227634317Q)
		(CKEQ (IPLUS 146317Q 5230002636Q)
		      5230151155Q)
		(CKEQ (IQUOTIENT 146317Q 5230002636Q)
		      0)
		(CKEQ (IREMAINDER 10650Q -66166Q)
		      10650Q)
		(CKEQ (IDIFFERENCE 10650Q -66166Q)
		      77036Q)
		(CKEQ (IPLUS 10650Q -66166Q)
		      -55316Q)
		(CKEQ (IQUOTIENT 10650Q -66166Q)
		      0)
		(CKEQ (ITIMES 10650Q -66166Q)
		      -736601560Q)
		(CKEQ (IREMAINDER -5 -32766Q)
		      -5)
		(CKEQ (IDIFFERENCE -5 -32766Q)
		      32761Q)
		(CKEQ (IPLUS -5 -32766Q)
		      -32773Q)
		(CKEQ (IQUOTIENT -5 -32766Q)
		      0)
		(CKEQ (ITIMES -5 -32766Q)
		      206716Q)
		(CKEQ (IREMAINDER 113703Q -2733011560Q)
		      113703Q)
		(CKEQ (IDIFFERENCE 113703Q -2733011560Q)
		      2733125463Q)
		(CKEQ (IPLUS 113703Q -2733011560Q)
		      -2732675655Q)
		(CKEQ (IQUOTIENT 113703Q -2733011560Q)
		      0)
		(CKEQ (IPLUS 1124452466Q 0)
		      1124452466Q)
		(CKEQ (ITIMES 1124452466Q 0)
		      0)
		(CKEQ (IDIFFERENCE -4 0)
		      -4)
		(CKEQ (IPLUS -4 0)
		      -4)
		(CKEQ (ITIMES -4 0)
		      0)
		(CKEQ (IREMAINDER 1 -5061322610Q)
		      1)
		(CKEQ (IDIFFERENCE 1 -5061322610Q)
		      5061322611Q)
		(CKEQ (IPLUS 1 -5061322610Q)
		      -5061322607Q)
		(CKEQ (IQUOTIENT 1 -5061322610Q)
		      0)
		(CKEQ (ITIMES 1 -5061322610Q)
		      -5061322610Q)
		(CKEQ (IREMAINDER 0 113566Q)
		      0)
		(CKEQ (IDIFFERENCE 0 113566Q)
		      -113566Q)
		(CKEQ (IPLUS 0 113566Q)
		      113566Q)
		(CKEQ (IQUOTIENT 0 113566Q)
		      0)
		(CKEQ (ITIMES 0 113566Q)
		      0)
		(CKEQ (IREMAINDER -5 3)
		      -2)
		(CKEQ (IDIFFERENCE -5 3)
		      -10Q)
		(CKEQ (IPLUS -5 3)
		      -2)
		(CKEQ (IQUOTIENT -5 3)
		      -1)
		(CKEQ (ITIMES -5 3)
		      -17Q)
		(CKEQ (IREMAINDER 5 -145277Q)
		      5)
		(CKEQ (IDIFFERENCE 5 -145277Q)
		      145304Q)
		(CKEQ (IPLUS 5 -145277Q)
		      -145272Q)
		(CKEQ (IQUOTIENT 5 -145277Q)
		      0)
		(CKEQ (ITIMES 5 -145277Q)
		      -772673Q)
		(CKEQ (IREMAINDER 3216Q -7537760666Q)
		      3216Q)
		(CKEQ (IDIFFERENCE 3216Q -7537760666Q)
		      7537764104Q)
		(CKEQ (IPLUS 3216Q -7537760666Q)
		      -7537755450Q)
		(CKEQ (IQUOTIENT 3216Q -7537760666Q)
		      0)
		(CKEQ (IREMAINDER 4601134451Q -154036Q)
		      131071Q)
		(CKEQ (IDIFFERENCE 4601134451Q -154036Q)
		      4601310507Q)
		(CKEQ (IPLUS 4601134451Q -154036Q)
		      4600760413Q)
		(CKEQ (IQUOTIENT 4601134451Q -154036Q)
		      -26410Q)
		(CKEQ (IREMAINDER 0 2)
		      0)
		(CKEQ (IDIFFERENCE 0 2)
		      -2)
		(CKEQ (IPLUS 0 2)
		      2)
		(CKEQ (IQUOTIENT 0 2)
		      0)
		(CKEQ (ITIMES 0 2)
		      0))))

(!FNUMTEST
  (LAMBDA NIL                                                (* JonL " 7-Nov-84 17:57")
    (!FNUMTEST1)
    (!FNUMTEST2)
    (!FNUMTEST3)
    (!FNUMTEST4)
    (!FNUMTEST5)))

(!FNUMTEST1
  (LAMBDA NIL                                                (* JonL " 7-Nov-84 16:29")
                                                             (* Some very simple cases especially involving a 16-bit
							     overflow)
    (CKFEQ (FPLUS -65536.0 1.0)
	   -65535.0)
    (CKFEQ (FDIFFERENCE -65536.0 1.0)
	   -65537.0)
    (CKFEQ (FTIMES -65536.0 1.0)
	   -65536.0)
    (CKFEQ (FQUOTIENT -65536.0 1.0)
	   -65536.0)
    (CKFEQ (FPLUS 65535.0 0.0)
	   65535.0)
    (CKFEQ (FDIFFERENCE 65535.0 0.0)
	   65535.0)
    (CKFEQ (FTIMES 65535.0 0.0)
	   0.0)
    (CKFEQ (FPLUS 65535.0 -1.0)
	   65534.0)
    (CKFEQ (FDIFFERENCE 65535.0 -1.0)
	   65536.0)
    (CKFEQ (FTIMES 65535.0 -1.0)
	   -65535.0)
    (CKFEQ (FQUOTIENT 65535.0 -1.0)
	   -65535.0)
    (CKFEQ (FPLUS 65535.0 1.0)
	   65536.0)
    (CKFEQ (FDIFFERENCE 65535.0 1.0)
	   65534.0)
    (CKFEQ (FTIMES 65535.0 1.0)
	   65535.0)
    (CKFEQ (FQUOTIENT 65535.0 1.0)
	   65535.0)
    (CKFEQ (FPLUS 0.0 -65536.0)
	   -65536.0)
    (CKFEQ (FDIFFERENCE 0.0 -65536.0)
	   65536.0)
    (CKFEQ (FTIMES 0.0 -65536.0)
	   0.0)
    (CKFEQ (FQUOTIENT 0.0 -65536.0)
	   0.0)))

(!FNUMTEST2
  (LAMBDA NIL                                                (* JonL " 7-Nov-84 18:47")
    (for I F FORM from 0 to (SUB1 BITSPERCELL)
       do (SETQ F (create FLOATP
			  FLOATCONTENTS _(LOGXOR (MASK.1'S I 1)
						 (CONSTANT (fetch (FLOATP FLOATCONTENTS)
							      of (create FLOATP
									 EXPONENT _ 201Q))))))
	  (SETQ FORM (LIST (QUOTE FPLUS)
			   0.0
			   (CONCAT "{ 2.0 xor 2^" I)))
	  (!CKFEQ (FPLUS 0.0 F)
		  F FORM)
	  (!CKFEQ (FTIMES 1.0 F)
		  F
		  (QUOTE (FTIMES 1.0 F))))))

(!FNUMTEST3
  (LAMBDA NIL                                                (* JonL " 7-Nov-84 16:32")
                                                             (* Check for coercions)
    (CKFEQ (FPLUS -200000Q 1)
	   -65535.0)
    (CKFEQ (FDIFFERENCE -200000Q 1)
	   -65537.0)
    (CKFEQ (FTIMES -200000Q 1)
	   -65536.0)
    (CKFEQ (FQUOTIENT -200000Q 1)
	   -65536.0)
    (CKFEQ (FPLUS -65536.0 1)
	   -65535.0)
    (CKFEQ (FDIFFERENCE -65536.0 1)
	   -65537.0)
    (CKFEQ (FTIMES -65536.0 1)
	   -65536.0)
    (CKFEQ (FQUOTIENT -65536.0 1)
	   -65536.0)
    (CKFEQ (FPLUS -200000Q 1.0)
	   -65535.0)
    (CKFEQ (FDIFFERENCE -200000Q 1.0)
	   -65537.0)
    (CKFEQ (FTIMES -200000Q 1.0)
	   -65536.0)
    (CKFEQ (FQUOTIENT -200000Q 1.0)
	   -65536.0)))

(!FNUMTEST4
  (LAMBDA NIL                                                (* JonL " 7-Nov-84 20:58")
                                                             (* Some random kludgy number tests)
    (!CKFEQ (FPLUS 1.234568 1.111111)
	    2.345679
	    (QUOTE (FPLUS 1.234568 1.111111)))
    (!CKFEQ (FPLUS (DEFERREDCONSTANT (create FLOATP
					     FLOATCONTENTS _ 7747403121Q))
		   1.111111)
	    (DEFERREDCONSTANT (create FLOATP
				      FLOATCONTENTS _ 10005417632Q))
	    (QUOTE (FPLUS "1.2345678" 1.111111)))))

(!FNUMTEST5
  (LAMBDA NIL                                                (* JonL " 7-Nov-84 16:33")
                                                             (* Check out the comparators)
    (MTCHECK (FGREATERP 1.0 0.0))
    (MTCHECK (NOT (FGREATERP -1.0 0.0)))))

(!MIXNUMTEST
  [LAMBDA NIL                                                (* lmm "19-Jul-84 18:07")
    (!RANDNUMTEST)
    (PROGN (CKEQ (DIFFERENCE -200000Q -200000Q)
		 0)
	   (CKEQ (PLUS -200000Q -200000Q)
		 -400000Q)
	   (CKEQ (QUOTIENT -200000Q -200000Q)
		 1)
	   (CKEQ (DIFFERENCE -200000Q 177777Q)
		 -377777Q)
	   (CKEQ (PLUS -200000Q 177777Q)
		 -1)
	   (CKEQ (QUOTIENT -200000Q 177777Q)
		 -1)
	   (CKFEQ (DIFFERENCE -200000Q 0.0)
		  -65536.0)
	   (CKFEQ (TIMES -200000Q 0.0)
		  0.0)
	   (CKFEQ (PLUS -200000Q 0.0)
		  -65536.0)
	   (CKEQ (DIFFERENCE -200000Q 0)
		 -200000Q)
	   (CKEQ (TIMES -200000Q 0)
		 0)
	   (CKEQ (PLUS -200000Q 0)
		 -200000Q)
	   (CKEQ (DIFFERENCE -200000Q 3)
		 -200003Q)
	   (CKEQ (TIMES -200000Q 3)
		 -600000Q)
	   (CKEQ (PLUS -200000Q 3)
		 -177775Q)
	   (CKEQ (QUOTIENT -200000Q 3)
		 -52525Q)
	   (CKFEQ (DIFFERENCE -200000Q -1.0)
		  -65535.0)
	   (CKFEQ (TIMES -200000Q -1.0)
		  65536.0)
	   (CKFEQ (PLUS -200000Q -1.0)
		  -65537.0)
	   (CKFEQ (QUOTIENT -200000Q -1.0)
		  65536.0)
	   (CKEQ (DIFFERENCE -200000Q -1)
		 -177777Q)
	   (CKEQ (TIMES -200000Q -1)
		 200000Q)
	   (CKEQ (PLUS -200000Q -1)
		 -200001Q)
	   (CKEQ (QUOTIENT -200000Q -1)
		 200000Q)
	   (CKEQ (DIFFERENCE -200000Q 2)
		 -200002Q)
	   (CKEQ (TIMES -200000Q 2)
		 -400000Q)
	   (CKEQ (PLUS -200000Q 2)
		 -177776Q)
	   (CKEQ (QUOTIENT -200000Q 2)
		 -100000Q)
	   (CKFEQ (DIFFERENCE -200000Q 1.0)
		  -65537.0)
	   (CKFEQ (TIMES -200000Q 1.0)
		  -65536.0)
	   (CKFEQ (PLUS -200000Q 1.0)
		  -65535.0)
	   (CKFEQ (QUOTIENT -200000Q 1.0)
		  -65536.0)
	   (CKEQ (DIFFERENCE -200000Q 1)
		 -200001Q)
	   (CKEQ (TIMES -200000Q 1)
		 -200000Q)
	   (CKEQ (PLUS -200000Q 1)
		 -177777Q)
	   (CKEQ (QUOTIENT -200000Q 1)
		 -200000Q)
	   (CKEQ (DIFFERENCE 177777Q -200000Q)
		 377777Q)
	   (CKEQ (PLUS 177777Q -200000Q)
		 -1)
	   (CKEQ (QUOTIENT 177777Q -200000Q)
		 0)
	   (CKEQ (DIFFERENCE 177777Q 177777Q)
		 0)
	   (CKEQ (PLUS 177777Q 177777Q)
		 377776Q)
	   (CKEQ (QUOTIENT 177777Q 177777Q)
		 1)
	   (CKFEQ (DIFFERENCE 177777Q 0.0)
		  65535.0)
	   (CKFEQ (TIMES 177777Q 0.0)
		  0.0)
	   (CKFEQ (PLUS 177777Q 0.0)
		  65535.0)
	   (CKEQ (DIFFERENCE 177777Q 0)
		 177777Q)
	   (CKEQ (TIMES 177777Q 0)
		 0)
	   (CKEQ (PLUS 177777Q 0)
		 177777Q)
	   (CKEQ (DIFFERENCE 177777Q 3)
		 177774Q)
	   (CKEQ (TIMES 177777Q 3)
		 577775Q)
	   (CKEQ (PLUS 177777Q 3)
		 200002Q)
	   (CKEQ (QUOTIENT 177777Q 3)
		 52525Q)
	   (CKFEQ (DIFFERENCE 177777Q -1.0)
		  65536.0)
	   (CKFEQ (TIMES 177777Q -1.0)
		  -65535.0)
	   (CKFEQ (PLUS 177777Q -1.0)
		  65534.0)
	   (CKFEQ (QUOTIENT 177777Q -1.0)
		  -65535.0)
	   (CKEQ (DIFFERENCE 177777Q -1)
		 200000Q)
	   (CKEQ (TIMES 177777Q -1)
		 -177777Q)
	   (CKEQ (PLUS 177777Q -1)
		 177776Q)
	   (CKEQ (QUOTIENT 177777Q -1)
		 -177777Q)
	   (CKEQ (DIFFERENCE 177777Q 2)
		 177775Q)
	   (CKEQ (TIMES 177777Q 2)
		 377776Q)
	   (CKEQ (PLUS 177777Q 2)
		 200001Q)
	   (CKEQ (QUOTIENT 177777Q 2)
		 77777Q)
	   (CKFEQ (DIFFERENCE 177777Q 1.0)
		  65534.0)
	   (CKFEQ (TIMES 177777Q 1.0)
		  65535.0)
	   (CKFEQ (PLUS 177777Q 1.0)
		  65536.0)
	   (CKFEQ (QUOTIENT 177777Q 1.0)
		  65535.0)
	   (CKEQ (DIFFERENCE 177777Q 1)
		 177776Q)
	   (CKEQ (TIMES 177777Q 1)
		 177777Q)
	   (CKEQ (PLUS 177777Q 1)
		 200000Q)
	   (CKEQ (QUOTIENT 177777Q 1)
		 177777Q)
	   (CKFEQ (DIFFERENCE 0.0 -200000Q)
		  65536.0)
	   (CKFEQ (TIMES 0.0 -200000Q)
		  0.0)
	   (CKFEQ (PLUS 0.0 -200000Q)
		  -65536.0)
	   (CKFEQ (QUOTIENT 0.0 -200000Q)
		  0.0)
	   (CKFEQ (DIFFERENCE 0.0 177777Q)
		  -65535.0)
	   (CKFEQ (TIMES 0.0 177777Q)
		  0.0)
	   (CKFEQ (PLUS 0.0 177777Q)
		  65535.0)
	   (CKFEQ (QUOTIENT 0.0 177777Q)
		  0.0)
	   (CKFEQ (DIFFERENCE 0.0 0.0)
		  0.0)
	   (CKFEQ (TIMES 0.0 0.0)
		  0.0)
	   (CKFEQ (PLUS 0.0 0.0)
		  0.0)
	   (CKFEQ (DIFFERENCE 0.0 0)
		  0.0)
	   (CKFEQ (TIMES 0.0 0)
		  0.0)
	   (CKFEQ (PLUS 0.0 0)
		  0.0)
	   (CKFEQ (DIFFERENCE 0.0 3)
		  -3.0)
	   (CKFEQ (TIMES 0.0 3)
		  0.0)
	   (CKFEQ (PLUS 0.0 3)
		  3.0)
	   (CKFEQ (QUOTIENT 0.0 3)
		  0.0)
	   (CKFEQ (DIFFERENCE 0.0 -1.0)
		  1.0)
	   (CKFEQ (TIMES 0.0 -1.0)
		  0.0)
	   (CKFEQ (PLUS 0.0 -1.0)
		  -1.0)
	   (CKFEQ (QUOTIENT 0.0 -1.0)
		  0.0)
	   (CKFEQ (DIFFERENCE 0.0 -1)
		  1.0)
	   (CKFEQ (TIMES 0.0 -1)
		  0.0)
	   (CKFEQ (PLUS 0.0 -1)
		  -1.0)
	   (CKFEQ (QUOTIENT 0.0 -1)
		  0.0)
	   (CKFEQ (DIFFERENCE 0.0 2)
		  -2.0)
	   (CKFEQ (TIMES 0.0 2)
		  0.0)
	   (CKFEQ (PLUS 0.0 2)
		  2.0)
	   (CKFEQ (QUOTIENT 0.0 2)
		  0.0)
	   (CKFEQ (DIFFERENCE 0.0 1.0)
		  -1.0)
	   (CKFEQ (TIMES 0.0 1.0)
		  0.0)
	   (CKFEQ (PLUS 0.0 1.0)
		  1.0)
	   (CKFEQ (QUOTIENT 0.0 1.0)
		  0.0)
	   (CKFEQ (DIFFERENCE 0.0 1)
		  -1.0)
	   (CKFEQ (TIMES 0.0 1)
		  0.0)
	   (CKFEQ (PLUS 0.0 1)
		  1.0)
	   (CKFEQ (QUOTIENT 0.0 1)
		  0.0)
	   (CKEQ (DIFFERENCE 0 -200000Q)
		 200000Q)
	   (CKEQ (TIMES 0 -200000Q)
		 0)
	   (CKEQ (PLUS 0 -200000Q)
		 -200000Q)
	   (CKEQ (QUOTIENT 0 -200000Q)
		 0)
	   (CKEQ (DIFFERENCE 0 177777Q)
		 -177777Q)
	   (CKEQ (TIMES 0 177777Q)
		 0)
	   (CKEQ (PLUS 0 177777Q)
		 177777Q)
	   (CKEQ (QUOTIENT 0 177777Q)
		 0)
	   (CKFEQ (DIFFERENCE 0 0.0)
		  0.0)
	   (CKFEQ (TIMES 0 0.0)
		  0.0)
	   (CKFEQ (PLUS 0 0.0)
		  0.0)
	   (CKEQ (DIFFERENCE 0 0)
		 0)
	   (CKEQ (TIMES 0 0)
		 0)
	   (CKEQ (PLUS 0 0)
		 0)
	   (CKEQ (DIFFERENCE 0 3)
		 -3)
	   (CKEQ (TIMES 0 3)
		 0)
	   (CKEQ (PLUS 0 3)
		 3)
	   (CKEQ (QUOTIENT 0 3)
		 0)
	   (CKFEQ (DIFFERENCE 0 -1.0)
		  1.0)
	   (CKFEQ (TIMES 0 -1.0)
		  0.0)
	   (CKFEQ (PLUS 0 -1.0)
		  -1.0)
	   (CKFEQ (QUOTIENT 0 -1.0)
		  0.0)
	   (CKEQ (DIFFERENCE 0 -1)
		 1)
	   (CKEQ (TIMES 0 -1)
		 0)
	   (CKEQ (PLUS 0 -1)
		 -1)
	   (CKEQ (QUOTIENT 0 -1)
		 0)
	   (CKEQ (DIFFERENCE 0 2)
		 -2)
	   (CKEQ (TIMES 0 2)
		 0)
	   (CKEQ (PLUS 0 2)
		 2)
	   (CKEQ (QUOTIENT 0 2)
		 0)
	   (CKFEQ (DIFFERENCE 0 1.0)
		  -1.0)
	   (CKFEQ (TIMES 0 1.0)
		  0.0)
	   (CKFEQ (PLUS 0 1.0)
		  1.0)
	   (CKFEQ (QUOTIENT 0 1.0)
		  0.0)
	   (CKEQ (DIFFERENCE 0 1)
		 -1)
	   (CKEQ (TIMES 0 1)
		 0)
	   (CKEQ (PLUS 0 1)
		 1)
	   (CKEQ (QUOTIENT 0 1)
		 0)
	   (CKEQ (DIFFERENCE 3 -200000Q)
		 200003Q)
	   (CKEQ (TIMES 3 -200000Q)
		 -600000Q)
	   (CKEQ (PLUS 3 -200000Q)
		 -177775Q)
	   (CKEQ (QUOTIENT 3 -200000Q)
		 0)
	   (CKEQ (DIFFERENCE 3 177777Q)
		 -177774Q)
	   (CKEQ (TIMES 3 177777Q)
		 577775Q)
	   (CKEQ (PLUS 3 177777Q)
		 200002Q)
	   (CKEQ (QUOTIENT 3 177777Q)
		 0)
	   (CKFEQ (DIFFERENCE 3 0.0)
		  3.0)
	   (CKFEQ (TIMES 3 0.0)
		  0.0)
	   (CKFEQ (PLUS 3 0.0)
		  3.0)
	   (CKEQ (DIFFERENCE 3 0)
		 3)
	   (CKEQ (TIMES 3 0)
		 0)
	   (CKEQ (PLUS 3 0)
		 3)
	   (CKEQ (DIFFERENCE 3 3)
		 0)
	   (CKEQ (TIMES 3 3)
		 11Q)
	   (CKEQ (PLUS 3 3)
		 6)
	   (CKEQ (QUOTIENT 3 3)
		 1)
	   (CKFEQ (DIFFERENCE 3 -1.0)
		  4.0)
	   (CKFEQ (TIMES 3 -1.0)
		  -3.0)
	   (CKFEQ (PLUS 3 -1.0)
		  2.0)
	   (CKFEQ (QUOTIENT 3 -1.0)
		  -3.0)
	   (CKEQ (DIFFERENCE 3 -1)
		 4)
	   (CKEQ (TIMES 3 -1)
		 -3)
	   (CKEQ (PLUS 3 -1)
		 2)
	   (CKEQ (QUOTIENT 3 -1)
		 -3)
	   (CKEQ (DIFFERENCE 3 2)
		 1)
	   (CKEQ (TIMES 3 2)
		 6)
	   (CKEQ (PLUS 3 2)
		 5)
	   (CKEQ (QUOTIENT 3 2)
		 1)
	   (CKFEQ (DIFFERENCE 3 1.0)
		  2.0)
	   (CKFEQ (TIMES 3 1.0)
		  3.0)
	   (CKFEQ (PLUS 3 1.0)
		  4.0)
	   (CKFEQ (QUOTIENT 3 1.0)
		  3.0)
	   (CKEQ (DIFFERENCE 3 1)
		 2)
	   (CKEQ (TIMES 3 1)
		 3)
	   (CKEQ (PLUS 3 1)
		 4)
	   (CKEQ (QUOTIENT 3 1)
		 3)
	   (CKFEQ (DIFFERENCE -1.0 -200000Q)
		  65535.0)
	   (CKFEQ (TIMES -1.0 -200000Q)
		  65536.0)
	   (CKFEQ (PLUS -1.0 -200000Q)
		  -65537.0)
	   (CKFUZZYEQ (QUOTIENT -1.0 -200000Q)
		      .00001525879)
	   (CKFEQ (DIFFERENCE -1.0 177777Q)
		  -65536.0)
	   (CKFEQ (TIMES -1.0 177777Q)
		  -65535.0)
	   (CKFEQ (PLUS -1.0 177777Q)
		  65534.0)
	   (CKFUZZYEQ (QUOTIENT -1.0 177777Q)
		      -.00001525902)
	   (CKFEQ (DIFFERENCE -1.0 0.0)
		  -1.0)
	   (CKFEQ (TIMES -1.0 0.0)
		  0.0)
	   (CKFEQ (PLUS -1.0 0.0)
		  -1.0)
	   (CKFEQ (DIFFERENCE -1.0 0)
		  -1.0)
	   (CKFEQ (TIMES -1.0 0)
		  0.0)
	   (CKFEQ (PLUS -1.0 0)
		  -1.0)
	   (CKFEQ (DIFFERENCE -1.0 3)
		  -4.0)
	   (CKFEQ (TIMES -1.0 3)
		  -3.0)
	   (CKFEQ (PLUS -1.0 3)
		  2.0)
	   (CKFUZZYEQ (QUOTIENT -1.0 3)
		      -.3333333)
	   (CKFEQ (DIFFERENCE -1.0 -1.0)
		  0.0)
	   (CKFEQ (TIMES -1.0 -1.0)
		  1.0)
	   (CKFEQ (PLUS -1.0 -1.0)
		  -2.0)
	   (CKFEQ (QUOTIENT -1.0 -1.0)
		  1.0)
	   (CKFEQ (DIFFERENCE -1.0 -1)
		  0.0)
	   (CKFEQ (TIMES -1.0 -1)
		  1.0)
	   (CKFEQ (PLUS -1.0 -1)
		  -2.0)
	   (CKFEQ (QUOTIENT -1.0 -1)
		  1.0)
	   (CKFEQ (DIFFERENCE -1.0 2)
		  -3.0)
	   (CKFEQ (TIMES -1.0 2)
		  -2.0)
	   (CKFEQ (PLUS -1.0 2)
		  1.0)
	   (CKFEQ (QUOTIENT -1.0 2)
		  -.5)
	   (CKFEQ (DIFFERENCE -1.0 1.0)
		  -2.0)
	   (CKFEQ (TIMES -1.0 1.0)
		  -1.0)
	   (CKFEQ (PLUS -1.0 1.0)
		  0.0)
	   (CKFEQ (QUOTIENT -1.0 1.0)
		  -1.0)
	   (CKFEQ (DIFFERENCE -1.0 1)
		  -2.0)
	   (CKFEQ (TIMES -1.0 1)
		  -1.0)
	   (CKFEQ (PLUS -1.0 1)
		  0.0)
	   (CKFEQ (QUOTIENT -1.0 1)
		  -1.0)
	   (CKEQ (DIFFERENCE -1 -200000Q)
		 177777Q)
	   (CKEQ (TIMES -1 -200000Q)
		 200000Q)
	   (CKEQ (PLUS -1 -200000Q)
		 -200001Q)
	   (CKEQ (QUOTIENT -1 -200000Q)
		 0)
	   (CKEQ (DIFFERENCE -1 177777Q)
		 -200000Q)
	   (CKEQ (TIMES -1 177777Q)
		 -177777Q)
	   (CKEQ (PLUS -1 177777Q)
		 177776Q)
	   (CKEQ (QUOTIENT -1 177777Q)
		 0)
	   (CKFEQ (DIFFERENCE -1 0.0)
		  -1.0)
	   (CKFEQ (TIMES -1 0.0)
		  0.0)
	   (CKFEQ (PLUS -1 0.0)
		  -1.0)
	   (CKEQ (DIFFERENCE -1 0)
		 -1)
	   (CKEQ (TIMES -1 0)
		 0)
	   (CKEQ (PLUS -1 0)
		 -1)
	   (CKEQ (DIFFERENCE -1 3)
		 -4)
	   (CKEQ (TIMES -1 3)
		 -3)
	   (CKEQ (PLUS -1 3)
		 2)
	   (CKEQ (QUOTIENT -1 3)
		 0)
	   (CKFEQ (DIFFERENCE -1 -1.0)
		  0.0)
	   (CKFEQ (TIMES -1 -1.0)
		  1.0)
	   (CKFEQ (PLUS -1 -1.0)
		  -2.0)
	   (CKFEQ (QUOTIENT -1 -1.0)
		  1.0)
	   (CKEQ (DIFFERENCE -1 -1)
		 0)
	   (CKEQ (TIMES -1 -1)
		 1)
	   (CKEQ (PLUS -1 -1)
		 -2)
	   (CKEQ (QUOTIENT -1 -1)
		 1)
	   (CKEQ (DIFFERENCE -1 2)
		 -3)
	   (CKEQ (TIMES -1 2)
		 -2)
	   (CKEQ (PLUS -1 2)
		 1)
	   (CKEQ (QUOTIENT -1 2)
		 0)
	   (CKFEQ (DIFFERENCE -1 1.0)
		  -2.0)
	   (CKFEQ (TIMES -1 1.0)
		  -1.0)
	   (CKFEQ (PLUS -1 1.0)
		  0.0)
	   (CKFEQ (QUOTIENT -1 1.0)
		  -1.0)
	   (CKEQ (DIFFERENCE -1 1)
		 -2)
	   (CKEQ (TIMES -1 1)
		 -1)
	   (CKEQ (PLUS -1 1)
		 0)
	   (CKEQ (QUOTIENT -1 1)
		 -1)
	   (CKEQ (DIFFERENCE 2 -200000Q)
		 200002Q)
	   (CKEQ (TIMES 2 -200000Q)
		 -400000Q)
	   (CKEQ (PLUS 2 -200000Q)
		 -177776Q)
	   (CKEQ (QUOTIENT 2 -200000Q)
		 0)
	   (CKEQ (DIFFERENCE 2 177777Q)
		 -177775Q)
	   (CKEQ (TIMES 2 177777Q)
		 377776Q)
	   (CKEQ (PLUS 2 177777Q)
		 200001Q)
	   (CKEQ (QUOTIENT 2 177777Q)
		 0)
	   (CKEQ (DIFFERENCE 2 0.0)
		 2.0)
	   (CKFEQ (TIMES 2 0.0)
		  0.0)
	   (CKFEQ (PLUS 2 0.0)
		  2.0)
	   (CKEQ (DIFFERENCE 2 0)
		 2)
	   (CKEQ (TIMES 2 0)
		 0)
	   (CKEQ (PLUS 2 0)
		 2)
	   (CKEQ (DIFFERENCE 2 3)
		 -1)
	   (CKEQ (TIMES 2 3)
		 6)
	   (CKEQ (PLUS 2 3)
		 5)
	   (CKEQ (QUOTIENT 2 3)
		 0)
	   (CKFEQ (DIFFERENCE 2 -1.0)
		  3.0)
	   (CKFEQ (TIMES 2 -1.0)
		  -2.0)
	   (CKFEQ (PLUS 2 -1.0)
		  1.0)
	   (CKFEQ (QUOTIENT 2 -1.0)
		  -2.0)
	   (CKEQ (DIFFERENCE 2 -1)
		 3)
	   (CKEQ (TIMES 2 -1)
		 -2)
	   (CKEQ (PLUS 2 -1)
		 1)
	   (CKEQ (QUOTIENT 2 -1)
		 -2)
	   (CKEQ (DIFFERENCE 2 2)
		 0)
	   (CKEQ (TIMES 2 2)
		 4)
	   (CKEQ (PLUS 2 2)
		 4)
	   (CKEQ (QUOTIENT 2 2)
		 1)
	   (CKFEQ (DIFFERENCE 2 1.0)
		  1.0)
	   (CKFEQ (TIMES 2 1.0)
		  2.0)
	   (CKFEQ (PLUS 2 1.0)
		  3.0)
	   (CKFEQ (QUOTIENT 2 1.0)
		  2.0)
	   (CKEQ (DIFFERENCE 2 1)
		 1)
	   (CKEQ (TIMES 2 1)
		 2)
	   (CKEQ (PLUS 2 1)
		 3)
	   (CKEQ (QUOTIENT 2 1)
		 2)
	   (CKFEQ (DIFFERENCE 1.0 -200000Q)
		  65537.0)
	   (CKFEQ (TIMES 1.0 -200000Q)
		  -65536.0)
	   (CKFEQ (PLUS 1.0 -200000Q)
		  -65535.0)
	   (CKFUZZYEQ (QUOTIENT 1.0 -200000Q)
		      -.00001525879)
	   (CKFEQ (DIFFERENCE 1.0 177777Q)
		  -65534.0)
	   (CKFEQ (TIMES 1.0 177777Q)
		  65535.0)
	   (CKFEQ (PLUS 1.0 177777Q)
		  65536.0)
	   (CKFUZZYEQ (QUOTIENT 1.0 177777Q)
		      .00001525902)
	   (CKFEQ (DIFFERENCE 1.0 0.0)
		  1.0)
	   (CKFEQ (TIMES 1.0 0.0)
		  0.0)
	   (CKFEQ (PLUS 1.0 0.0)
		  1.0)
	   (CKFEQ (DIFFERENCE 1.0 0)
		  1.0)
	   (CKFEQ (TIMES 1.0 0)
		  0.0)
	   (CKFEQ (PLUS 1.0 0)
		  1.0)
	   (CKFEQ (DIFFERENCE 1.0 3)
		  -2.0)
	   (CKFEQ (TIMES 1.0 3)
		  3.0)
	   (CKFEQ (PLUS 1.0 3)
		  4.0)
	   (CKFUZZYEQ (QUOTIENT 1.0 3)
		      .3333333)
	   (CKFEQ (DIFFERENCE 1.0 -1.0)
		  2.0)
	   (CKFEQ (TIMES 1.0 -1.0)
		  -1.0)
	   (CKFEQ (PLUS 1.0 -1.0)
		  0.0)
	   (CKFEQ (QUOTIENT 1.0 -1.0)
		  -1.0)
	   (CKFEQ (DIFFERENCE 1.0 -1)
		  2.0)
	   (CKFEQ (TIMES 1.0 -1)
		  -1.0)
	   (CKFEQ (PLUS 1.0 -1)
		  0.0)
	   (CKFEQ (QUOTIENT 1.0 -1)
		  -1.0)
	   (CKFEQ (DIFFERENCE 1.0 2)
		  -1.0)
	   (CKFEQ (TIMES 1.0 2)
		  2.0)
	   (CKFEQ (PLUS 1.0 2)
		  3.0)
	   (CKFEQ (QUOTIENT 1.0 2)
		  .5)
	   (CKFEQ (DIFFERENCE 1.0 1.0)
		  0.0)
	   (CKFEQ (TIMES 1.0 1.0)
		  1.0)
	   (CKFEQ (PLUS 1.0 1.0)
		  2.0)
	   (CKFEQ (QUOTIENT 1.0 1.0)
		  1.0)
	   (CKFEQ (DIFFERENCE 1.0 1)
		  0.0)
	   (CKFEQ (TIMES 1.0 1)
		  1.0)
	   (CKFEQ (PLUS 1.0 1)
		  2.0)
	   (CKFEQ (QUOTIENT 1.0 1)
		  1.0)
	   (CKEQ (DIFFERENCE 1 -200000Q)
		 200001Q)
	   (CKEQ (TIMES 1 -200000Q)
		 -200000Q)
	   (CKEQ (PLUS 1 -200000Q)
		 -177777Q)
	   (CKEQ (QUOTIENT 1 -200000Q)
		 0)
	   (CKEQ (DIFFERENCE 1 177777Q)
		 -177776Q)
	   (CKEQ (TIMES 1 177777Q)
		 177777Q)
	   (CKEQ (PLUS 1 177777Q)
		 200000Q)
	   (CKEQ (QUOTIENT 1 177777Q)
		 0)
	   (CKFEQ (DIFFERENCE 1 0.0)
		  1.0)
	   (CKFEQ (TIMES 1 0.0)
		  0.0)
	   (CKFEQ (PLUS 1 0.0)
		  1.0)
	   (CKEQ (DIFFERENCE 1 0)
		 1)
	   (CKEQ (TIMES 1 0)
		 0)
	   (CKEQ (PLUS 1 0)
		 1)
	   (CKEQ (DIFFERENCE 1 3)
		 -2)
	   (CKEQ (TIMES 1 3)
		 3)
	   (CKEQ (PLUS 1 3)
		 4)
	   (CKEQ (QUOTIENT 1 3)
		 0)
	   (CKEQ (DIFFERENCE 1 -1.0)
		 2.0)
	   (CKFEQ (TIMES 1 -1.0)
		  -1.0)
	   (CKFEQ (PLUS 1 -1.0)
		  0.0)
	   (CKFEQ (QUOTIENT 1 -1.0)
		  -1.0)
	   (CKEQ (DIFFERENCE 1 -1)
		 2)
	   (CKEQ (TIMES 1 -1)
		 -1)
	   (CKEQ (PLUS 1 -1)
		 0)
	   (CKEQ (QUOTIENT 1 -1)
		 -1)
	   (CKEQ (DIFFERENCE 1 2)
		 -1)
	   (CKEQ (TIMES 1 2)
		 2)
	   (CKEQ (PLUS 1 2)
		 3)
	   (CKEQ (QUOTIENT 1 2)
		 0)
	   (CKFEQ (DIFFERENCE 1 1.0)
		  0.0)
	   (CKFEQ (TIMES 1 1.0)
		  1.0)
	   (CKFEQ (PLUS 1 1.0)
		  2.0)
	   (CKFEQ (QUOTIENT 1 1.0)
		  1.0)
	   (CKEQ (DIFFERENCE 1 1)
		 0)
	   (CKEQ (TIMES 1 1)
		 1)
	   (CKEQ (PLUS 1 1)
		 2)
	   (CKEQ (QUOTIENT 1 1)
		 1])
)



(* "Compiler error may prevent some of the above functions from getting compiled")

(DECLARE: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY 
[MAPC (OR (FILEFNSLST (QUOTE MACROTESTAUX))
	  (QUOTE (PUSH.TEST)))
      (FUNCTION (LAMBDA (X)
			(MOVD? (QUOTE NILL)
			       X]
)
(PUTPROPS MACROTESTAUX COPYRIGHT ("Xerox Corporation" 3700Q 3701Q))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (3310Q 20067Q (!FVARTEST 3322Q . 3770Q) (PUSH.TEST 3772Q . 5721Q) (CALLS.FIRSTARGTEST 
5723Q . 6272Q) (CALLS.LASTARGTEST 6274Q . 6774Q) (CALLS.TOOFEWARGS 6776Q . 7472Q) (FVAR.FREE 7474Q . 
11020Q) (FVAR.TEST 11022Q . 12151Q) (FVAR.TEST2 12153Q . 12452Q) (FVAR.TEST3 12454Q . 12663Q) (
FN.FIRSTARG.FVARS 12665Q . 13175Q) (FN.FIRSTARG.PVARS.FVARS 13177Q . 13561Q) (FN.LASTARG.FVARS 13563Q
 . 14173Q) (FN.LASTARG.FVARS.PVARS 14175Q . 14670Q) (FVAR.TESTN 14672Q . 15074Q) (FN.FREE.SKIPPVARS 
15076Q . 15402Q) (FN.FREEPVAR 15404Q . 15745Q) (FN.FVAR3 15747Q . 16134Q) (FN.FREEARG 16136Q . 16335Q)
 (FN.FR1 16337Q . 16620Q) (FN.FR2 16622Q . 17103Q) (FN.FR3 17105Q . 17526Q) (FAULTTEST 17530Q . 20065Q
)) (20413Q 246456Q (!NUMBERTEST 20425Q . 20772Q) (!NUMTEST1 20774Q . 31247Q) (!NUMTEST2 31251Q . 
41611Q) (!NUMTEST3 41613Q . 52720Q) (!NUMTEST4 52722Q . 64753Q) (!NUMTEST5 64755Q . 76701Q) (!NUMTEST6
 76703Q . 107223Q) (!RANDNUMTEST 107225Q . 111105Q) (!RANDNUMTEST1 111107Q . 124024Q) (!RANDNUMTEST2 
124026Q . 143354Q) (!RANDNUMTEST3 143356Q . 162401Q) (!RANDNUMTEST4 162403Q . 200141Q) (!FNUMTEST 
200143Q . 200470Q) (!FNUMTEST1 200472Q . 203004Q) (!FNUMTEST2 203006Q . 204154Q) (!FNUMTEST3 204156Q
 . 205635Q) (!FNUMTEST4 205637Q . 206742Q) (!FNUMTEST5 206744Q . 207407Q) (!MIXNUMTEST 207411Q . 
246454Q)))))
STOP
\ No newline at end of file
diff --git a/internal/library/MAILCLIENT b/internal/library/MAILCLIENT
new file mode 100644
index 00000000..d069553f
--- /dev/null
+++ b/internal/library/MAILCLIENT
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "15-Jun-90 18:05:32" {DSK}<usr>local>lde>lispcore>internal>library>MAILCLIENT.;2 55455  

      changes to%:  (VARS MAILCLIENTCOMS)
                    (FNS \GV.SENDMESSAGE)

      previous date%: " 9-Nov-89 15:31:24" {DSK}<usr>local>lde>lispcore>internal>library>MAILCLIENT.;1
)


(* ; "
Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT MAILCLIENTCOMS)

(RPAQQ MAILCLIENTCOMS
       ((COMS                                                (* ; "Sending mail")
              (FNS GV.STARTSEND GV.ADDRECIPIENT GV.CHECKVALIDITY GV.STARTITEM GV.ADDTOITEM GV.SEND 
                   MS.EXPAND)
                                                             (* ; "Internal Sending")
              (FNS MS.SENDOPERATION \FINDMAILSERVER \MAILSERVERSOCKETS \RECEIVEACK \RESPTOCHECKVAL 
                   \RESPTOEXPAND \RESPTOSTARTSEND)
              (INITVARS (\MAILIOTIMEOUT NIL)
                     (\MAILSERVERENQUIRYSOC 46)
                     (\MAILSERVERNAME '(Maildrop . ms))
                     (\MAILSERVERPOLLINGSOC 44)
                     (\MAILSERVERSOCKETCACHE)
                     (\MAILSERVERRETRIEVALSOC 47))
              (GLOBALVARS \MAILIOTIMEOUT \MAILSERVERENQUIRYSOC \MAILSERVERNAME \MAILSERVERPOLLINGSOC
                     \MAILSERVERSOCKETCACHE \MAILSERVERRETRIEVALSOC)
              (ADDVARS (\SYSTEMCACHEVARS \MAILSERVERSOCKETCACHE)))
        (COMS                                                (* ; "Receiving mail")
              (FNS GV.PORTFROMNAME GV.POLLNEWMAIL GV.OPENMAILBOX GV.NEXTMESSAGE GV.RETRIEVEMESSAGE 
                   GV.CLOSEMAILBOX)
              (ADDVARS (MAILSERVERTYPES (GV GV.POLLNEWMAIL GV.OPENMAILBOX GV.NEXTMESSAGE 
                                            GV.RETRIEVEMESSAGE GV.CLOSEMAILBOX GV.PORTFROMNAME)))
              (COMS                                          (* ; "Not currently used")
                    (FNS GV.READTOC GV.WRITETOC GV.DELETEMESSAGE))
                                                             (* ; "Internal Receiving")
              (FNS MS.RETRIEVEOPERATION \CONNECTTOMAILSERVER \RESPTOOPENMAILBOX \RESPTONEXTMESSAGE 
                   \RESPTORETRIEVEMESSAGE \RECEIVELONGWORD \CACHED.HOST.NAME)
              (INITVARS (GV.MAILBOX.TIMEOUT 12000)
                     (*GV-SHOW-POSTMARK*)
                     (\CACHED.HOST.NAMES))
              (ADDVARS (\SYSTEMCACHEVARS \CACHED.HOST.NAMES))
              (GLOBALVARS GV.MAILBOX.TIMEOUT \CACHED.HOST.NAMES))
        (COMS                                                (* ; "LAFITEMODE GV")
              (ALISTS (LAFITEMODELST GV GRAPEVINE))
              (FNS GV.INIT.MAIL.USER GETMAILSERVEROPS \GV.MAILSERVERTYPE)
              (FNS \GV.SENDMESSAGE \GV.SENDRECIPIENTS)
              (FNS \GV.SEND.PARSE \GV.PARSERECIPIENTS \GV.PARSERECIPIENTS1 \GV.FIND.NON.SPACE 
                   \GV.PARSE.SIMPLE.RECIPIENT \GV.EXTRACT.FIELD \GV.HANDLE.DL \GV.PARSE.FAILED 
                   \LAFITE.CHOOSE.REPLYTO)
              (FNS \GV.MESSAGE.P \GV.MESSAGE.FROM.SELF.P GV.MAKEANSWERFORM \GV.DIFFERENCE)
              (ADDVARS (MAILSERVERTYPES)
                     (LAFITEDLDIRECTORIES)
                     (LAFITE.PERSONAL.VARS LAFITE.GV.FROM.FIELD))
              (INITVARS (ARPANETGATEWAY.REGISTRY 'AG)
                     (LAFITEREPLYTOMENU NIL)
                     (LAFITEDL.EXT "DL")
                     (LAFITE.GV.FROM.FIELD))
              (ADDVARS (LAFITESUPPORT (GV "LafiteSupport.pa"))
                     (LAFITEMENUVARS LAFITEREPLYTOMENU))
              (VARS LAFITEREPLYTOMENUITEMS)
              (PROP FILEDEF MAINTAIN))
        (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS MAILPORT GVMAILPARSE)
               (COMS * MAILCLIENTCONSTANTCOMS)
               [P (CL:PROCLAIM '(GLOBAL MAILSERVERTYPES ARPANETGATEWAY.REGISTRY 
                                       LAFITEREPLYTOMENUITEMS LAFITEREPLYTOMENU))
                  (CL:PROCLAIM '(CL:SPECIAL *MSGOUTSTREAM*]
               (FILES (SOURCE)
                      LAFITEDECLS)
               (FILES (LOADCOMP)
                      GRAPEVINE PUP BSP)
               (LOCALVARS . T))
        (DECLARE%: DONTEVAL@LOAD DOCOPY [P (CL:PROCLAIM '(GLOBAL LAFITE.GV.FROM.FIELD LAFITEDL.EXT 
                                                                LAFITEDLDIRECTORIES))
                                           (CL:PROCLAIM '(CL:SPECIAL *GV-SHOW-POSTMARK*]
               (FILES GRAPEVINE))))



(* ; "Sending mail")

(DEFINEQ

(GV.STARTSEND
(LAMBDA (SENDER KEY RETURN VALIDATEFLG) (* bvm%: " 5-Nov-84 15:39") (* ;;; "returns either a socket to use to send the rest of the message on or NIL") (LET (SENDINGSOCKET STARTSENDRESULT) (COND ((NOT (SETQ SENDINGSOCKET (\FINDMAILSERVER))) (* ; "Can't find a maildrop at all") NIL) ((SETQ STARTSENDRESULT (MS.SENDOPERATION \OP.STARTSEND SENDINGSOCKET (LIST (\CHECKNAME SENDER) (\CHECKKEY KEY) (\CHECKNAME RETURN) (LIST \3BYTEKLUDGEKEY (COND (VALIDATEFLG 1) (T 0)))) (FUNCTION \RESPTOSTARTSEND))) SENDINGSOCKET) (T (* ; "print the reason for failure") (AND NIL (printout PROMPTWINDOW "Couldn't start sending the message - reason: " STARTSENDRESULT T)) NIL))))
)

(GV.ADDRECIPIENT
(LAMBDA (SOCKET NAME) (* M.Yonke "15-JUN-83 15:20") (MS.SENDOPERATION \OP.ADDRECIPIENT SOCKET (LIST (\CHECKNAME NAME))))
)

(GV.CHECKVALIDITY
(LAMBDA (SOCKET) (* M.Yonke "15-JUN-83 15:53") (MS.SENDOPERATION \OP.CHECKVALIDITY SOCKET NIL (FUNCTION \RESPTOCHECKVAL)))
)

(GV.STARTITEM
(LAMBDA (SOCKET TYPE) (* M.Yonke "15-JUN-83 15:31") (* ; "If TYPE is not supplied assume text") (MS.SENDOPERATION \OP.STARTITEM SOCKET (LIST (OR (AND TYPE (SMALLP TYPE)) \I.TEXT))))
)

(GV.ADDTOITEM
(LAMBDA (SOCKET STR) (* bvm%: "24-Jan-86 11:26") (* ;;; "Can't use \SENDITEM here because not in usual Grapevine STR format -- no maxLength or padding -- so we do it by hand and no response is given") (PROG ((OUTSTREAM (fetch GVOUTSTREAM of SOCKET)) WASOPEN INSTREAM %#CHARS) (SETQ %#CHARS (OR (SELECTQ (TYPENAME STR) (STRINGP (NCHARS STR)) (STREAM (GETFILEINFO (COND ((OPENED STR) (SETQ WASOPEN (SETQ INSTREAM STR))) (T (SETQ INSTREAM (OPENSTREAM STR (QUOTE INPUT))))) (QUOTE LENGTH))) (LITATOM (COND ((INFILEP STR) (GETFILEINFO (SETQ INSTREAM (OPENSTREAM STR (QUOTE INPUT))) (QUOTE LENGTH))))) NIL) (NCHARS (SETQ STR (MKSTRING STR))))) (COND ((AND INSTREAM (NEQ (GETFILEPTR INSTREAM) 0)) (SETFILEPTR INSTREAM 0))) (MS.SENDOPERATION \OP.ADDTOITEM SOCKET) (while (> %#CHARS MAX.SMALLP) do (* ;; "Stream bigger than can be sent in one chunk.  Note this cannot be the string case, because all strings have lengths le MAX.SMALLP") (\WOUT OUTSTREAM MAX.SMALLP) (COPYBYTES INSTREAM OUTSTREAM MAX.SMALLP) (SETQ %#CHARS (- %#CHARS MAX.SMALLP)) (MS.SENDOPERATION \OP.ADDTOITEM SOCKET)) (\WOUT OUTSTREAM %#CHARS) (COND (INSTREAM (COPYBYTES INSTREAM OUTSTREAM) (OR WASOPEN (CLOSEF INSTREAM))) (T (for CHAR instring STR do (BOUT OUTSTREAM CHAR))))))
)

(GV.SEND
(LAMBDA (SOCKET) (* bvm%: "23-Mar-84 12:42") (MS.SENDOPERATION \OP.SEND SOCKET NIL (FUNCTION \RECEIVEACK)))
)

(MS.EXPAND
(LAMBDA (SOCKET NAME) (* M.Yonke "15-JUN-83 15:53") (* ;;; "Does the mailserver Expand operation -- named to avoid conflict with the database version -- DBEXPAND") (MS.SENDOPERATION \OP.MSEXPAND SOCKET (LIST (\CHECKNAME NAME)) (FUNCTION \RESPTOEXPAND)))
)
)



(* ; "Internal Sending")

(DEFINEQ

(MS.SENDOPERATION
(LAMBDA (OP SOCKET ARGS RESPONSEFN) (* ; "Edited  3-Sep-87 18:09 by bvm:") (* ;;; "basic workhorse for communicating with a mail server --- sends an OP and ARGS and fields a response, if appropriate") (COND (SOCKET (COND ((NLSETQ (LET ((STREAM (fetch GVOUTSTREAM of SOCKET))) (\WOUT STREAM OP) (for ARG in ARGS do (\SENDITEM STREAM ARG)))) (COND (RESPONSEFN (CAR (NLSETQ (PROGN (FORCEOUTPUT (fetch GVOUTSTREAM of SOCKET)) (CL:FUNCALL RESPONSEFN (fetch GVINSTREAM of SOCKET)))))) (T T))))) (T (* ; "We're in the middle --- nothing for it but to bail out") EC.STREAMLOST)))
)

(\FINDMAILSERVER
(LAMBDA (ERRORFLG) (* M.Yonke "15-JUN-83 15:16") (* ;;; "Open a BSP connection to a nearby, responsive mail server and returns it") (if (OPENCLOSESTSOCKET (\MAILSERVERSOCKETS ERRORFLG) \MAILSERVERPOLLINGSOC \MAILSERVERENQUIRYSOC NIL \MAILIOTIMEOUT) elseif ERRORFLG then (ERROR "Couldn't open connection for" \MAILSERVERNAME) NIL))
)

(\MAILSERVERSOCKETS
(LAMBDA (ERRORFLG) (* bvm%: "21-MAY-83 20:00") (PROG (SOCKETS) (RETURN (COND ((AND \MAILSERVERSOCKETCACHE (NOT (TIMEREXPIRED? (CAR \MAILSERVERSOCKETCACHE)))) (CDR \MAILSERVERSOCKETCACHE)) (T (SETQ \MAILSERVERSOCKETCACHE (AND (SETQ SOCKETS (LOCATESOCKETS \MAILSERVERNAME ERRORFLG)) (CONS (SETUPTIMER \MAILSOCKETTIMEOUT) SOCKETS))) SOCKETS)))))
)

(\RECEIVEACK
(LAMBDA (STREAM) (* M.Yonke " 3-JUN-83 16:43") (* ; "any byte will do --- it seems to be 0 when I've noticed") (if (BIN STREAM) then T))
)

(\RESPTOCHECKVAL
(LAMBDA (INSTREAM) (* bvm%: "24-Jan-86 11:29") (* ;; "As per documentation --- bad guys followed by count of good guys which I CONS on the front") (bind N until (EQ (SETQ N (\WIN INSTREAM)) 0) collect (CONS N (\RECEIVERNAME INSTREAM)) finally (RETURN (CONS (\WIN INSTREAM) $$VAL))))
)

(\RESPTOEXPAND
(LAMBDA (INSTREAM) (* bvm%: "11-MAY-83 16:11") (* ;; "As per documentation --- names followed by a code which I interpret and CONS on the front") (while (\RECEIVEBOOL INSTREAM) collect (\RECEIVERNAME INSTREAM) finally (RETURN (CONS (SELECTQ (BIN INSTREAM) ((0 2) T) ((1 3) EC.BADRNAME) (SHOULDNT)) $$VAL))))
)

(\RESPTOSTARTSEND
(LAMBDA (INSTREAM) (* M.Yonke "26-MAY-83 10:45") (SELECTC (BIN INSTREAM) (\RC.SENDSTARTED T) (\RC.PASSWORDINVALID (QUOTE InvalidPassword)) (\RC.SENDERNOTREGISTERED (QUOTE SenderNotRegistered)) (\RC.RETURNTONOTREGISTERED (QUOTE ReturnToNotRegistered)) (\RC.COMMUNICATIONFAILURE (QUOTE NetworkCommunicationsFailure)) (SHOULDNT)))
)
)

(RPAQ? \MAILIOTIMEOUT NIL)

(RPAQ? \MAILSERVERENQUIRYSOC 46)

(RPAQ? \MAILSERVERNAME '(Maildrop . ms))

(RPAQ? \MAILSERVERPOLLINGSOC 44)

(RPAQ? \MAILSERVERSOCKETCACHE )

(RPAQ? \MAILSERVERRETRIEVALSOC 47)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \MAILIOTIMEOUT \MAILSERVERENQUIRYSOC \MAILSERVERNAME \MAILSERVERPOLLINGSOC 
       \MAILSERVERSOCKETCACHE \MAILSERVERRETRIEVALSOC)
)

(ADDTOVAR \SYSTEMCACHEVARS \MAILSERVERSOCKETCACHE)



(* ; "Receiving mail")

(DEFINEQ

(GV.PORTFROMNAME
(LAMBDA (SERVERNAME) (* bvm%: " 1-Jan-84 17:11") (AND (SETQ SERVERNAME (GV.READCONNECT SERVERNAME)) (ETHERPORT SERVERNAME)))
)

(GV.POLLNEWMAIL
(LAMBDA (GVPORT REGISTEREDNAME) (* bvm%: "14-Nov-84 10:10") (PROG ((SOC (\GETMISCSOCKET)) (OUTPUP (ALLOCATE.PUP)) (RESULT (QUOTE ?)) INPUP) (SETUPPUP OUTPUP (fetch (MAILPORT HOST#) of GVPORT) (fetch (MAILPORT SOCKET#) of GVPORT) \PT.LAURELCHECK NIL SOC T) (PUTPUPSTRING OUTPUP REGISTEREDNAME) (to \MAXETHERTRIES when (SETQ INPUP (EXCHANGEPUPS SOC OUTPUP NIL T)) do (SELECTC (fetch PUPTYPE of INPUP) (\PT.NEWMAIL (SETQ RESULT T) (RETURN)) (\PT.NONEWMAIL (SETQ RESULT NIL) (RETURN)) (\PT.NOMAILBOX (RETURN)) (\PT.ERROR (AND PUPTRACEFLG (PRINTERRORPUP INPUP PUPTRACEFILE)) (COND ((EQ (fetch ERRORPUPCODE of INPUP) \PUPE.NOSOCKET) (RETURN)))) NIL) finally (AND PUPTRACEFLG (printout PUPTRACEFILE "Mail check timed out" T))) (AND INPUP (RELEASE.PUP INPUP)) (RELEASE.PUP OUTPUP) (RETURN RESULT)))
)

(GV.OPENMAILBOX
(LAMBDA (GVPORT REGISTEREDNAME PASSWORD MAILSERVER) (* bvm%: "24-Feb-86 17:11") (SELECTQ (GV.POLLNEWMAIL GVPORT REGISTEREDNAME) (NIL (QUOTE EMPTY)) (? NIL) (LET (MAILBOX INBOXRESULT) (COND ((AND (SETQ MAILBOX (\CONNECTTOMAILSERVER GVPORT)) (SETQ INBOXRESULT (CAR (NLSETQ (MS.RETRIEVEOPERATION \OP.OPENINBOX MAILBOX (LIST (\CHECKNAME REGISTEREDNAME) (\CHECKKEY PASSWORD)) (FUNCTION \RESPTOOPENMAILBOX)))))) (COND ((SMALLP INBOXRESULT) (create OPENEDMAILBOX MAILBOX _ MAILBOX PROPERTIES _ (LIST (QUOTE %#OFMESSAGES) INBOXRESULT))) (T (* ; "Return failure reason") (create OPENEDMAILBOX MAILBOX _ NIL PROPERTIES _ INBOXRESULT))))))))
)

(GV.NEXTMESSAGE
(LAMBDA (MAILBOX) (* DECLARATIONS%: (RECORD (ANOTHERMESSAGE? ARCHIVED? DELETED?))) (* bvm%: " 5-Nov-84 13:13") (LET (RESULT) (SETQ RESULT (MS.RETRIEVEOPERATION \OP.NEXTMESSAGE MAILBOX NIL (FUNCTION \RESPTONEXTMESSAGE))) (AND (fetch ANOTHERMESSAGE? of RESULT) (LIST (QUOTE DELETED) (fetch DELETED? of RESULT) (QUOTE ARCHIVED) (fetch ARCHIVED? of RESULT)))))
)

(GV.RETRIEVEMESSAGE
(LAMBDA (MAILBOX MSGOUTFILE) (* ; "Edited  6-May-88 16:32 by bvm") (LET ((*MSGOUTSTREAM* (GETSTREAM MSGOUTFILE (QUOTE OUTPUT)))) (MS.RETRIEVEOPERATION \OP.READMESSAGE MAILBOX NIL (FUNCTION \RESPTORETRIEVEMESSAGE))))
)

(GV.CLOSEMAILBOX
(LAMBDA (MAILBOX FLUSHP) (* bvm%: " 9-May-84 14:13") (COND ((BSPOPENP (fetch GVINSTREAM of MAILBOX)) (PROG1 (COND (FLUSHP (MS.RETRIEVEOPERATION \OP.FLUSH MAILBOX NIL (FUNCTION \RECEIVEACK)))) (CLOSEBSPSTREAM (fetch GVINSTREAM of MAILBOX) \ETHERTIMEOUT)))))
)
)

(ADDTOVAR MAILSERVERTYPES (GV GV.POLLNEWMAIL GV.OPENMAILBOX GV.NEXTMESSAGE GV.RETRIEVEMESSAGE 
                                  GV.CLOSEMAILBOX GV.PORTFROMNAME))



(* ; "Not currently used")

(DEFINEQ

(GV.READTOC
(LAMBDA (MAILBOX) (* M.Yonke "25-MAY-83 14:37") (MS.RETRIEVEOPERATION \OP.READTOC MAILBOX NIL (FUNCTION \RECEIVESTRING)))
)

(GV.WRITETOC
(LAMBDA (MAILBOX REMARK) (* M.Yonke "25-MAY-83 14:37") (MS.RETRIEVEOPERATION \OP.WRITETOC MAILBOX (LIST REMARK) (FUNCTION \RECEIVEACK)))
)

(GV.DELETEMESSAGE
(LAMBDA (MAILBOX) (* M.Yonke "25-MAY-83 14:37") (MS.RETRIEVEOPERATION \OP.DELETEMESSAGE MAILBOX NIL (FUNCTION \RECEIVEACK)))
)
)



(* ; "Internal Receiving")

(DEFINEQ

(MS.RETRIEVEOPERATION
(LAMBDA (OP MAILBOX ARGS RESPONSEFN) (* ; "Edited  3-Sep-87 18:09 by bvm:") (* ;;; "basic workhorse for communicating with a mail server --- sends an OP and ARGS to MAILBOX and fields a response, if appropriate") (LET ((OUTSTREAM (fetch GVOUTSTREAM of MAILBOX))) (\WOUT OUTSTREAM OP) (for E in ARGS do (\SENDITEM OUTSTREAM E)) (FORCEOUTPUT OUTSTREAM) (COND (RESPONSEFN (CL:FUNCALL RESPONSEFN (fetch GVINSTREAM of MAILBOX))) (T T))))
)

(\CONNECTTOMAILSERVER
(LAMBDA (PORT) (* bvm%: "24-Feb-86 17:10") (* ;;; "Open a BSP connection to mail server.  Its error handler defined as ERROR! so that BAD.STATE.FOR.BIN etc suppressed") (RESETVARS ((\RTP.DEFAULTTIMEOUT GV.MAILBOX.TIMEOUT)) (* ;; "Crufty!!!! OPENBSPSTREAM should allow RFC timeout to be specified") (RETURN (\OPENGVCONNECTION (CONS (CAR PORT) \MAILSERVERRETRIEVALSOC) NIL (FUNCTION ERROR!)))))
)

(\RESPTOOPENMAILBOX
(LAMBDA (INSTREAM) (* bvm%: " 5-Nov-84 16:29") (SELECTC (\BIN INSTREAM) (\RC.NAMEANDPASSWORDVALID (\WIN INSTREAM)) (\RC.BADPASSWORD (QUOTE BadPassword)) (PROGN (* ;; "There are actually 5 values for the return code, but most of them are impossible, since Lafite has authenticated NAME") NIL)))
)

(\RESPTONEXTMESSAGE
(LAMBDA (INSTREAM) (* bvm%: "11-MAY-83 15:55") (LIST (\RECEIVEBOOL INSTREAM) (\RECEIVEBOOL INSTREAM) (\RECEIVEBOOL INSTREAM)))
)

(\RESPTORETRIEVEMESSAGE
(LAMBDA (INSTREAM) (* ; "Edited  3-Jun-88 18:32 by bvm") (until (\EOFP INSTREAM) bind TYPE BYTELEN GVHOST TIME SENDER ADDEDLENGTH do (* ;; "Read an item.  Ignore the ones not of type text or tedit formatting") (SETQ TYPE (\WIN INSTREAM)) (* ; "Item type") (SETQ BYTELEN (\RECEIVELONGWORD INSTREAM)) (* ; "Number of bytes long it is") (SELECTC TYPE (\I.TEXT (* ; "The text body") (if SENDER then (* ; "Print a postmark first") (SETQ ADDEDLENGTH (GETFILEPTR *MSGOUTSTREAM*)) (PRINTOUT *MSGOUTSTREAM* "GV-Info: " SENDER " at " (GDATE (ALTO.TO.LISP.DATE TIME)) " from " (\CACHED.HOST.NAME GVHOST) T) (SETQ ADDEDLENGTH (- (GETFILEPTR *MSGOUTSTREAM*) ADDEDLENGTH)) (* ; "May have to account for this later") (SETQ SENDER NIL)) (to BYTELEN do (* ; "Use \OUTCHAR to account for eol conventions") (\OUTCHAR *MSGOUTSTREAM* (BIN INSTREAM)))) ((CONS \I.TEDITFORMATTING (MKLIST \I.OLDTEDITFORMATTING)) (* ; "Various TEdit formatting") (if ADDEDLENGTH then (* ; "We prepended some text, so have to munge the formatting instead of copying it straight") (LET ((BUFFER (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (COPYBYTES INSTREAM BUFFER BYTELEN) (LA.ADJUST.FORMATTING BUFFER *MSGOUTSTREAM* ADDEDLENGTH)) else (* ; "Just append to the text--the two together make a valid textstream") (COPYBYTES INSTREAM *MSGOUTSTREAM* BYTELEN))) (OR (AND *GV-SHOW-POSTMARK* (SELECTC TYPE (\I.POSTMARK (* ; "6 bytes: pupaddr, timelo, timehi") (SETQ GVHOST (\WIN INSTREAM)) (SETQ TIME (NCREATE (QUOTE FIXP))) (replace LOWORD of TIME with (\WIN INSTREAM)) (replace HIWORD of TIME with (\WIN INSTREAM)) T) (\I.SENDER (SETQ SENDER (\RECEIVESTRING INSTREAM (\WIN INSTREAM)))) NIL)) (to BYTELEN do (BIN INSTREAM)))) (COND ((ODDP BYTELEN) (* ; "Eat padding byte") (BIN INSTREAM))) finally (BSPGETMARK INSTREAM)))
)

(\RECEIVELONGWORD
(LAMBDA (STREAM) (* bvm%: "11-MAY-83 14:49") (* ;; "Read a 32-bit number, low-word is first") (PROG ((LO (\WIN STREAM)) (HI (\WIN STREAM))) (RETURN (\MAKENUMBER HI LO))))
)

(\CACHED.HOST.NAME
(LAMBDA (HOST#) (* ; "Edited  6-May-88 17:25 by bvm") (* ;; "Return a name for HOST#.  Use cache to avoid recomputation") (OR (CDR (ASSOC HOST# \CACHED.HOST.NAMES)) (CDAR (push \CACHED.HOST.NAMES (CONS HOST# (ETHERHOSTNAME HOST# T))))))
)
)

(RPAQ? GV.MAILBOX.TIMEOUT 12000)

(RPAQ? *GV-SHOW-POSTMARK* )

(RPAQ? \CACHED.HOST.NAMES )

(ADDTOVAR \SYSTEMCACHEVARS \CACHED.HOST.NAMES)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS GV.MAILBOX.TIMEOUT \CACHED.HOST.NAMES)
)



(* ; "LAFITEMODE GV")


(ADDTOVAR LAFITEMODELST (GV 2 \GV.SEND.PARSE \GV.SENDMESSAGE GV.MAKEANSWERFORM GV.INIT.MAIL.USER
                                \GV.MESSAGE.P \GV.MESSAGE.FROM.SELF.P)
                            (GRAPEVINE . GV))
(DEFINEQ

(GV.INIT.MAIL.USER
(LAMBDA NIL (* ; "Edited  9-Nov-89 15:31 by bvm") (LET* ((GVUSERNAME (LAFITE.USER.NAME.FROM.LOGIN T T)) (FULLNAME (CONCAT (CAR GVUSERNAME) "." (CDR GVUSERNAME))) PASS MAILSERVERS AUTHENTICATED?) (COND ((NEQ (SETQ AUTHENTICATED? (GV.AUTHENTICATE GVUSERNAME (SETQ PASS (GV.MAKEKEY (CDR (\INTERNAL/GETPASSWORD)))))) T) (printout PROMPTWINDOW T "Cannot authenticate user " FULLNAME " because: " (SETQ \LAFITE.AUTHENTICATION.FAILURE AUTHENTICATED?) ".") NIL) ((NULL (SETQ MAILSERVERS (CDR (GV.EXPAND GVUSERNAME)))) (printout PROMPTWINDOW T "There are no mail servers for user " FULLNAME) NIL) (T (create LAFITEMODEDATA FULLUSERNAME _ FULLNAME UNPACKEDUSERNAME _ GVUSERNAME CREDENTIALS _ PASS SHORTUSERNAME _ FULLNAME FROMFIELD _ (AND LAFITE.GV.FROM.FIELD (LET ((PARSE (\GV.PARSERECIPIENTS1 LAFITE.GV.FROM.FIELD NIL T))) (* ;; "If the user's variable parses correctly into the authenticated user, then take it") (if (AND PARSE (NULL (CDR PARSE)) (STRING-EQUAL (CAAR PARSE) (CAR GVUSERNAME)) (STRING-EQUAL (CDAR PARSE) (CDR GVUSERNAME))) then LAFITE.GV.FROM.FIELD else (CL:FORMAT PROMPTWINDOW "~%%Can't use GV From field %"~A%" because it does not parse to current user %"~A%"" LAFITE.GV.FROM.FIELD FULLNAME) NIL))) MAILSERVERS _ (for MAILSERVER in MAILSERVERS bind SERVEROPS SERVERPORT SERVERDEF when (COND ((NULL (SETQ SERVEROPS (GETMAILSERVEROPS MAILSERVER))) NIL) ((NULL (SETQ SERVERPORT (CL:FUNCALL (fetch (MAILSERVEROPS SERVERPORTFROMNAME) of SERVEROPS) MAILSERVER))) (printout PROMPTWINDOW T "Can't find address of " MAILSERVER) NIL) (T (SETQ SERVERDEF (create MAILSERVER MAILPORT _ SERVERPORT MAILSERVERNAME _ MAILSERVER MAILSERVEROPS _ SERVEROPS)))) collect SERVERDEF))))))
)

(GETMAILSERVEROPS
(LAMBDA (MAILSERVER) (* bvm%: "12-Nov-84 17:52") (PROG ((SERVERTYPE (\GV.MAILSERVERTYPE MAILSERVER)) OPS) (RETURN (COND ((AND SERVERTYPE (SETQ OPS (OR (ASSOC SERVERTYPE MAILSERVERTYPES) (AND (EQ SERVERTYPE (QUOTE MTP)) (PROGN (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) MTP) (ASSOC SERVERTYPE MAILSERVERTYPES)))))) (CDR OPS)) (T (printout PROMPTWINDOW T "Lafite cannot retrieve mail from " MAILSERVER) NIL)))))
)

(\GV.MAILSERVERTYPE
(LAMBDA (MAILSERVERNAME) (* bvm%: " 9-Dec-85 17:03") (* ;;; "type is determined by the name currently") (COND ((STRING-EQUAL (SUBSTRING MAILSERVERNAME -3) ".MS") (QUOTE GV)) ((STRING-EQUAL MAILSERVERNAME "MAXC") (QUOTE MTP))))
)
)
(DEFINEQ

(\GV.SENDMESSAGE
  [LAMBDA (MSG PARSE EDITORWINDOW ABORTWINDOW)           (* ; "Edited 15-Jun-90 17:53 by jds")

(* ;;; "This is the real mail sender for the GrapeVine")

(* ;;; "MSG is the entire text of the message -- RECIPIENTS is a parsed list of recipients")

    (PROG ((PWINDOW (AND EDITORWINDOW (GETPROMPTWINDOW EDITORWINDOW)))
           (RECIPIENTS (fetch (GVMAILPARSE GVPRECIPIENTS) of PARSE))
           (FROMFIELD (fetch (GVMAILPARSE GVPFROM) of PARSE))
           (FORMATTING (fetch (GVMAILPARSE GVPFORMAT) of PARSE))
           (DATEFIELD (CONCAT "Date: " (DATE (DATEFORMAT NO.SECONDS TIME.ZONE SPACES))
                             LAFITEEOL))
           (FAILURECNT 0)
           (SENDER (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*))
           (UNPACKEDSENDER (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))
           DATELEN SENDINGSOCKET RECIPIENTSCHECK SENDRESULT SENDERFIELD ABORTMENU)
          [COND
             ((NOT (TYPENAMEP MSG 'STREAM))
              (RETURN (\ILLEGAL.ARG MSG]
          (SETQ FORMATTING (SELECTQ FORMATTING
                               ((MULTIMEDIA TEDIT)           (* ; 
                                                "Send with TEdit formatting, assuming there is any")
                                    (AND (TEDIT.FORMATTEDFILEP MSG)
                                         T))
                               (TEXT NIL)
                               (\ILLEGAL.ARG FORMATTING)))
          [COND
             (PWINDOW (CLEARW PWINDOW)
                    (CL:FORMAT PWINDOW "Delivering ~:[~;formatted ~]to ~D recipient~:P" FORMATTING
                           (LENGTH RECIPIENTS]
          [SETQ SENDERFIELD
           (COND
              (FROMFIELD                                     (* ; 
 "Test for valid From field.  We waited til now to do this so we didn't hold up start of delivery.")
               (if (for ADDR in FROMFIELD bind REG unless (STRPOS "@"
                                                                                     (CAR ADDR))
                          do                             (* ; "assume arpa addresses are valid")
                                (if (NLISTP (GV.EXPAND (if (EQ (SETQ REG (CDR ADDR))
                                                                       'NOREGISTRY)
                                                               then 
                                                             (* ; "The address had no registry.  We do it this odd way so that we can distinguish %"Fred%" from %"Fred.PA%" in the test below.")
                                                                     (CONS (CAR ADDR)
                                                                           (SETQ REG (CDR 
                                                                                       UNPACKEDSENDER
                                                                                          )))
                                                             else ADDR)))
                                    then [COND
                                                (PWINDOW (CLEARW PWINDOW)
                                                       (CL:FORMAT PWINDOW 
                                                              "From field not valid address: ~A"
                                                              (CONCAT (CAR ADDR)
                                                                     "." REG]
                                          (RETURN T)))
                   then (RETURN NIL))
               (if (AND (NULL (CDR FROMFIELD))
                            (STRING-EQUAL (CONCAT (CAAR FROMFIELD)
                                                 "."
                                                 (CDAR FROMFIELD))
                                   SENDER))
                   then                                  (* ; "From field is just a fancy way of writing the real from field, so adding a Sender field would be redundant")
                         NIL
                 else (CONCAT "Sender: " SENDER LAFITEEOL)))
              (T (CONCAT "From: " (OR (fetch (LAFITEMODEDATA FROMFIELD) of *LAFITE-MODE-DATA*
                                             )
                                      SENDER)
                        LAFITEEOL]
          [COND
             (FORMATTING (TEDIT.INSERT MSG DATEFIELD 1 NIL T)
                    (SETQ DATELEN (NCHARS DATEFIELD))
                    (CL:WHEN SENDERFIELD
                        (TEDIT.INSERT MSG SENDERFIELD (ADD1 DATELEN)
                               NIL T))                       (* ; 
                                   "Do tedit conversion now, before we have the bsp stream tied up")
                    [SETQ MSG (PROG1 (COERCETEXTOBJ MSG 'SPLIT)
                                  (TEDIT.DELETE MSG 1 (if SENDERFIELD
                                                          then (+ DATELEN (NCHARS SENDERFIELD))
                                                        else DATELEN)))]
                    (SETQ FORMATTING (CDR MSG))
                    (SETQ MSG (CAR MSG)))
             ((AND (TEXTSTREAMP MSG)
                   (TEDIT.FORMATTEDFILEP MSG))               (* ; "Message has formatting, but caller asked to send it as plain text.  Carefully coerce it, since TEDIT ns chars and image objects don't pass thru COPYBYTES very well")
              (SETQ MSG (LAFITE.MAKE.PLAIN.TEXTSTREAM MSG]
      STARTSEND
          (as I to 3 until (SETQ SENDINGSOCKET (GV.STARTSEND UNPACKEDSENDER
                                                                  (fetch (LAFITEMODEDATA 
                                                                                    CREDENTIALS)
                                                                     of *LAFITE-MODE-DATA*)
                                                                  UNPACKEDSENDER T))
             do                                          (* ; 
                                                           "loop 3 times trying to start this send")
                   (DISMISS 1000))
          [COND
             ((NULL SENDINGSOCKET)
              (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't connect to a maildrop"]
          (RESETSAVE NIL (LIST (FUNCTION GV.KILLSOCKET)
                               SENDINGSOCKET))
          (AND PWINDOW (printout PWINDOW '|...|))
          (COND
             ((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW 'ABORT))
              (ERROR!)))
          (SELECTQ (SETQ RECIPIENTSCHECK (\GV.SENDRECIPIENTS SENDINGSOCKET RECIPIENTS 
                                                EDITORWINDOW))
              (NIL                                           (* ; 
            "MS didn't like the recipients list -- this was already reported by \GV.SENDRECIPIENTS")
                   (RETURN NIL))
              (?                                             (* ; "Something went wrong, try again")
                 (GO TRYAGAIN))
              NIL)                                           (* ; "Everything is OK")
          (COND
             ((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW 'ABORT))
              (ERROR!)))                                     (* ; "send code to start sending text")
          (GV.STARTITEM SENDINGSOCKET)
          [COND
             ((NOT FORMATTING)
              (GV.ADDTOITEM SENDINGSOCKET DATEFIELD)
              (AND SENDERFIELD (GV.ADDTOITEM SENDINGSOCKET SENDERFIELD]
                                                             (* ; "send the message")
          (COND
             ((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW 'ABORT))
              (ERROR!)))
          (GV.ADDTOITEM SENDINGSOCKET MSG)               (* ; 
                                                           "tell the grapevine to send the message")
          (COND
             (FORMATTING (COND
                            ((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW 'ABORT))
                             (ERROR!)))
                    (GV.STARTITEM SENDINGSOCKET \I.TEDITFORMATTING)
                                                             (* ; "Send formatting info")
                    (GV.ADDTOITEM SENDINGSOCKET FORMATTING)))
          (COND
             ((NULL ABORTWINDOW))
             ((WINDOWPROP ABORTWINDOW 'ABORT)
              (ERROR!))
             (T                                              (* ; "Too late to abort now")
                (DELETEMENU [SETQ ABORTMENU (CAR (WINDOWPROP ABORTWINDOW 'MENU]
                       NIL ABORTWINDOW)))
          (COND
             ((EQ (SETQ SENDRESULT (GV.SEND SENDINGSOCKET))
                  T)
              (RETURN T)))
      TRYAGAIN
          [COND
             ((> (add FAILURECNT 1)
                 4)
              (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Several unsuccessful attempts"]
          (AND PWINDOW (printout PWINDOW " problems, trying again."))
          (GV.KILLSOCKET SENDINGSOCKET)                      (* ; "Just in case it's still alive")
          (COND
             (ABORTMENU                                      (* ; 
                                                         "Restore the Abort menu that we took down")
                    (ADDMENU ABORTMENU ABORTWINDOW '(0 . 0))
                    (SETQ ABORTMENU)))
          (GO STARTSEND])

(\GV.SENDRECIPIENTS
(LAMBDA (SOCKET RECIPIENTS EDITORWINDOW) (* DECLARATIONS%: (RECORD (%#OFVALIDRECIPIENTS . INVALIDRECIPIENTS)) (RECORD INVALIDRECIPIENT (RECIPIENT# . RECIPIENTNAME))) (* bvm%: " 6-Nov-84 11:53") (PROG (REASON VALIDITYRESULT INVALID) (COND ((NLISTP RECIPIENTS) (SETQ REASON "No recipients supplied")) (T (for R in RECIPIENTS do (GV.ADDRECIPIENT SOCKET R)) (SETQ VALIDITYRESULT (GV.CHECKVALIDITY SOCKET)) (COND ((NLISTP VALIDITYRESULT) (RETURN (QUOTE ?))) ((NULL (SETQ INVALID (fetch INVALIDRECIPIENTS of VALIDITYRESULT))) (* ; "everything went OK") (RETURN VALIDITYRESULT)) (T (* ; "GV didn't like some recipients") (SETQ REASON (\LAFITE.INVALID.RECIPIENTS (for RECIPIENT in INVALID collect (fetch (INVALIDRECIPIENT RECIPIENTNAME) of RECIPIENT)))))))) FAILED (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW REASON))))
)
)
(DEFINEQ

(\GV.SEND.PARSE
(LAMBDA (MSG EDITORWINDOW) (* ; "Edited  5-May-88 13:06 by bvm") (PROG ((REGISTRY (CDR (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) RECIPIENTS MSGFIELDS FROMFIELD SENDINGFORMAT HEADEREOF REPLYTO SUBJECT) (OR (SETQ MSGFIELDS (\LAFITE.PREPARE.SEND MSG EDITORWINDOW)) (RETURN)) (COND ((EQ (CAAR MSGFIELDS) (QUOTE EOF)) (SETQ HEADEREOF (CADR (pop MSGFIELDS))))) (for PAIR in MSGFIELDS do (SELECTQ (CAR PAIR) (Date (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Date not allowed")) ((To cc) (SETQ RECIPIENTS (NCONC RECIPIENTS (\GV.PARSERECIPIENTS (CDR PAIR) REGISTRY T EDITORWINDOW)))) (From (SETQ FROMFIELD (\GV.PARSERECIPIENTS (CDR PAIR) (QUOTE NOREGISTRY) T EDITORWINDOW))) (Reply-to (SETQ REPLYTO (\GV.PARSERECIPIENTS (CDR PAIR) REGISTRY T EDITORWINDOW))) (Sender (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Sender not allowed")) (Format (SETQ SENDINGFORMAT (CADR PAIR))) (Subject (SETQ SUBJECT (CADR PAIR))) NIL)) (COND ((NULL RECIPIENTS) (\SENDMESSAGEFAIL EDITORWINDOW "No recipients!") (RETURN NIL)) ((FMEMB NIL RECIPIENTS) (* ;; "if there is a NIL in RECIPIENTS then \GV.PARSERECIPIENTS couldn't parse something {it already reported it} therefore just get out now") (RETURN NIL))) (COND ((NULL SENDINGFORMAT) (SETQ SENDINGFORMAT (OR (\LAFITE.CHOOSE.MSG.FORMAT MSG HEADEREOF EDITORWINDOW) (RETURN))))) (COND ((AND EDITORWINDOW (NULL REPLYTO) (for GVNAME in RECIPIENTS thereis (EQ (NTHCHARCODE (CAR GVNAME) -1) (CHARCODE ^)))) (OR (\LAFITE.CHOOSE.REPLYTO MSG HEADEREOF FROMFIELD EDITORWINDOW) (RETURN)))) (RETURN (create GVMAILPARSE GVPSUBJECT _ SUBJECT GVPFROM _ FROMFIELD GVPFORMAT _ SENDINGFORMAT GVPRECIPIENTS _ RECIPIENTS))))
)

(\GV.PARSERECIPIENTS
(LAMBDA (FIELD REGISTRY INTERNALFLG EDITWINDOW) (* ; "Edited  9-Sep-87 16:27 by bvm:") (SETQ FIELD (COND ((LISTP FIELD) (for PIECE in FIELD join (\GV.PARSERECIPIENTS1 PIECE REGISTRY INTERNALFLG EDITWINDOW))) (T (\GV.PARSERECIPIENTS1 FIELD REGISTRY INTERNALFLG EDITWINDOW)))) (COND (INTERNALFLG FIELD) (T (CL:REMOVE-DUPLICATES FIELD :TEST (QUOTE STRING-EQUAL)))))
)

(\GV.PARSERECIPIENTS1
(LAMBDA (LINE REGISTRY INTERNALFLG EDITWINDOW RECURSIVE-P) (* ; "Edited 13-Jun-88 12:21 by bvm") (* ;;; "INTERNALFLG = T means produce addresses to give Grapevine;  NIL means give human-readable addresses") (PROG ((I 0) NC NOPEN CH ADDRESSES ADDR FAILURE OPEN CLOSE DOT ATSIGN START COLON COMSTART COMMENTS PRETTY DLNAME) (COND ((NULL LINE) (RETURN NIL))) (SETQ NC (NCHARS LINE)) NEXTADDR (if (>= I NC) then (* ; "done") (if COLON then (* ; "Slight missing semi-colon") (SETQ FAILURE #\:) (GO FAIL)) (RETURN (REVERSE ADDRESSES))) (CASE (SETQ CH (CL:CHAR LINE I)) ((#\Space #\Tab #\Newline) (* ; "Ignore leading whitespace") (add I 1) (GO NEXTADDR))) (SETQ START I) (SETQ OPEN (SETQ CLOSE (SETQ DOT (SETQ ATSIGN (SETQ COMMENTS NIL))))) THISCHAR (CASE CH (#\" (GO INQUOTE)) (#\( (GO INCOMMENT)) (#\[ (GO INDOMAIN)) ((#\) #\]) (* ; "Unbalanced stuff") (SETQ FAILURE CH) (GO FAIL)) (#\< (* ; "Start of address spec") (if OPEN then (SETQ FAILURE #\<) (GO FAIL) else (SETQ OPEN I))) (#\> (* ; "End of address spec") (if OPEN then (SETQ CLOSE I) else (SETQ FAILURE #\>) (GO FAIL))) (#\. (if (NOT CLOSE) then (* ; "Note placement of periods.  Ignore if outside <> address.") (SETQ DOT I))) (#\@ (if (NOT CLOSE) then (* ; "Note arpa address separator") (SETQ ATSIGN I) (SETQ DOT NIL))) (#\: (if (OR OPEN ATSIGN COLON) then (SETQ FAILURE "Invalid use of colon") (GO FAIL) else (if (EQ (\GV.FIND.NON.SPACE LINE (+ I 1) NC) #\;) then (* ; "DL in the form %"dlname:;%" -- get recipients from file") (SETQ ADDR (\GV.HANDLE.DL (SETQ DLNAME (\GV.EXTRACT.FIELD LINE START I)) INTERNALFLG EDITWINDOW)) (if (EQ (CAR ADDR) :ERROR) then (SETQ FAILURE (CADR ADDR)) (GO FAIL) else (SETQ ADDRESSES (NCONC ADDR ADDRESSES)) (SETQ DLNAME NIL)) else (* ; "Random phrase naming the group, followed by the addresses--just parse them as they come along, and note that we expect a semi-colon at some point.")) (SETQ COLON I) (add I 1) (GO NEXTADDR))) ((NIL #\, #\;) (* ; "end of address") (if (CASE CH (#\; (if (NOT COLON) then (SETQ FAILURE #\;) else (CASE (\GV.FIND.NON.SPACE LINE (+ I 1) NC) ((NIL #\,) (* ; "good--semi is at end of address.  Consider it eaten") (SETQ COLON NIL)) (T (* ; "Stuff after the semicolon is bad syntax") (SETQ FAILURE "Semi-colon must be at end of group specification"))))) ((NIL) (* ; "end of everything, check that there's no outstanding colon") (if COLON then (SETQ FAILURE #\:)))) then (* ; "Problem with this semi-colon") (GO FAIL)) (if (NEQ START I) then (* ; "there is a name") (if (NOT OPEN) then (* ; "simple address") (SETQ ADDR (\GV.PARSE.SIMPLE.RECIPIENT LINE START I DOT ATSIGN COMMENTS REGISTRY INTERNALFLG)) (if (EQ (CAR ADDR) :ERROR) then (SETQ FAILURE (CADR ADDR)) (GO FAIL)) elseif (NOT CLOSE) then (SETQ FAILURE #\<) (GO FAIL) else (* ; "real address is inside the <>") (SETQ ADDR (\GV.PARSE.SIMPLE.RECIPIENT LINE (+ OPEN 1) CLOSE DOT ATSIGN COMMENTS REGISTRY INTERNALFLG)) (if (EQ (CAR ADDR) :ERROR) then (SETQ FAILURE (CADR ADDR)) (GO FAIL)) (CASE INTERNALFLG ((NIL :BOTH) (* ; "Want pretty address--stick the reparsed real address inside the template") (SETQ PRETTY (CL:FORMAT NIL "~@[~A ~]<~A>~@[ ~A~]" (\GV.EXTRACT.FIELD LINE START OPEN) (if INTERNALFLG then (CAR ADDR) else ADDR) (\GV.EXTRACT.FIELD LINE (+ CLOSE 1) I))) (SETQ ADDR (if INTERNALFLG then (* ; "Want (pretty . internal)") (CONS PRETTY (CDR ADDR)) else PRETTY))))) (push ADDRESSES ADDR)) (add I 1) (GO NEXTADDR))) NEXT-I (SETQ CH (AND (< (add I 1) NC) (CL:CHAR LINE I))) (GO THISCHAR) INQUOTE (* ;; "Parse a quoted string--skip to next quote") (while (< (add I 1) NC) do (CASE (CL:CHAR LINE I) (#\" (* ; "end of quoted text") (GO NEXT-I)) (#\\ (* ; "quotes next char") (add I 1)))) (* ;; "If we get here, we have an unbalanced quote") (SETQ FAILURE #\") (GO FAIL) INCOMMENT (* ;; "Parse a comment in parens. Parentheses may be nested.  Add to set of comments") (SETQ COMSTART I) (SETQ NOPEN 1) (while (< (add I 1) NC) do (CASE (CL:CHAR LINE I) (#\) (if (EQ (SETQ NOPEN (- NOPEN 1)) 0) then (* ; "end of comment--parens are now matched") (if INTERNALFLG then (* ; "We will need to know how to strip comments") (push COMMENTS (LIST COMSTART (+ I 1)))) (GO NEXT-I))) (#\( (* ; "nested comment") (add NOPEN 1)) (#\\ (* ; "quotes next char") (add I 1)))) (* ;; "If we get here, we have an unbalanced paren") (SETQ FAILURE #\() (GO FAIL) INDOMAIN (* ;; "Parse a domain literal--string in square brackets.  These may not be nested.") (while (< (add I 1) NC) do (CASE (CL:CHAR LINE I) (#\] (* ; "end of literal") (GO NEXT-I)) (#\[ (* ; "unmatched") (RETURN)) (#\\ (* ; "quotes next char") (add I 1)))) (* ;; "If we get here, we have an unbalanced bracket") (SETQ FAILURE #\[) (GO FAIL) FAIL (RETURN (COND (RECURSIVE-P (LIST :ERROR FAILURE)) ((NOT EDITWINDOW) (* ; "No interaction, just show failure by returning (NIL)") (LIST NIL)) ((CL:CHARACTERP FAILURE) (\SENDMESSAGEFAIL EDITWINDOW (CL:FORMAT NIL "Error~@[ in ~A~]: " DLNAME) (CASE FAILURE (#\" "Unmatched quotation mark") (#\: "Incorrect group syntax--colon without terminating semi-colon") (T (CL:FORMAT NIL "Unmatched %"~C%"" FAILURE))))) (DLNAME (\SENDMESSAGEFAIL EDITWINDOW (CONCAT "In " DLNAME ": ") FAILURE)) (T (\SENDMESSAGEFAIL EDITWINDOW FAILURE))))))
)

(\GV.FIND.NON.SPACE
(LAMBDA (STR START END) (* ; "Edited 10-Jun-88 17:11 by bvm") (* ;; "returns the next non-white-space char in str from position start to end.") (bind CH do (if (>= START END) then (RETURN NIL) else (CASE (SETQ CH (CL:CHAR STR START)) ((#\Space #\Tab #\Newline) (add START 1)) (T (RETURN CH))))))
)

(\GV.PARSE.SIMPLE.RECIPIENT
(LAMBDA (FIELD START END DOT ATSIGN COMMENTS REGISTRY INTERNALFLG) (* ; "Edited 10-Jun-88 17:11 by bvm") (* ;;; "Parses a single ADDRESS, a list, and returns a proper address as a string, or if INTERNALFLG, in the form Grapevine likes") (COND ((EQ INTERNALFLG :BOTH) (LET ((INTERNAL (\GV.PARSE.SIMPLE.RECIPIENT FIELD START END DOT ATSIGN COMMENTS REGISTRY T))) (AND INTERNAL (CONS (\GV.PARSE.SIMPLE.RECIPIENT FIELD START END DOT ATSIGN COMMENTS REGISTRY NIL) INTERNAL)))) (INTERNALFLG (LET (TMP) (if (NULL DOT) then (SETQ TMP (\GV.EXTRACT.FIELD FIELD START END COMMENTS)) (if (NULL ATSIGN) then (* ; "use default registry") (if REGISTRY then (CONS TMP REGISTRY) else (LIST :ERROR (CONCAT "No registry given for addressee " TMP))) elseif (OR (EQ (CL:CHAR TMP 0) #\@) (EQ (CL:CHAR TMP (- (NCHARS TMP) 1)) #\@)) then (* ; "@ but null name or domain?") (\GV.PARSE.FAILED TMP) else (* ; "Assume name is otherwise good, use default arpa registry") (CONS TMP ARPANETGATEWAY.REGISTRY)) else (* ; "Take the domain/registry that's there") (SETQ TMP (CONS (\GV.EXTRACT.FIELD FIELD START DOT COMMENTS) (\GV.EXTRACT.FIELD FIELD (+ DOT 1) END COMMENTS))) (if (NULL (CDR TMP)) then (* ; "no domain?") (\GV.PARSE.FAILED (CONCAT (CAR TMP) ".")) else (RPLACD TMP (MKATOM (U-CASE (CDR TMP)))) (* ; "Grapevine registry must be atom, sigh.") TMP)))) ((OR ATSIGN DOT) (* ; "have an ARPA Internet address, or Grapevine address with registry--nothing to add to make user-sensible address") (if (NULL (\GV.FIND.NON.SPACE FIELD (OR ATSIGN DOT) END)) then (* ; "no domain") (\GV.PARSE.FAILED (\GV.EXTRACT.FIELD FIELD START END)) else (\GV.EXTRACT.FIELD FIELD START END))) (REGISTRY (* ; "Address without registry, supply default") (CONCAT (\GV.EXTRACT.FIELD FIELD START END) "." REGISTRY)) (T (* ; "Not even a default registry?  Punt") (\GV.EXTRACT.FIELD FIELD START END))))
)

(\GV.EXTRACT.FIELD
(LAMBDA (STR START END COMMENTS) (* ; "Edited 10-Jun-88 17:11 by bvm") (if COMMENTS then (LET (TMP PIECES) (SETQ PIECES (for PAIR in (if (CDR COMMENTS) then (REVERSE COMMENTS) else COMMENTS) when (AND (<= START (CAR PAIR)) (< (CAR PAIR) END) (PROG1 (SETQ TMP (\GV.EXTRACT.FIELD STR START (CAR PAIR))) (SETQ START (CADR PAIR)))) join (LIST " " TMP))) (if (SETQ TMP (\GV.EXTRACT.FIELD STR START END)) then (SETQ PIECES (NCONC PIECES (LIST " " TMP)))) (CONCATLIST (CDR PIECES))) else (* ; "trim white space from edges") (while (AND (< START END) (CASE (CL:CHAR STR START) ((#\Space #\Tab #\Newline) T))) do (add START 1)) (while (AND (< START END) (CASE (CL:CHAR STR (- END 1)) ((#\Space #\Tab #\Newline) T))) do (add END -1)) (AND (< START END) (CL:SUBSEQ STR START END))))
)

(\GV.HANDLE.DL
(LAMBDA (DL INTERNALFLG EDITWINDOW) (* ; "Edited 13-Jun-88 14:17 by bvm") (CASE INTERNALFLG ((NIL :BOTH) (* ; "Don't want the actual addresses, just something to stick in a header.  We assume user of :BOTH is answer, or something that is mainly concerned with textual presentation to user.") (LET ((STR (CONCAT DL ":;"))) (LIST (if INTERNALFLG then (* ; "(pretty . internal)") (LIST* STR STR NIL) else STR)))) (T (LET ((FILENAME (PACKFILENAME.STRING (QUOTE BODY) (if (EQL (CL:CHAR DL 0) #\") then (* ; "quoted file name, take off the quotes first") (CL:SUBSEQ DL 1 (- (CL:LENGTH DL) 1)) else DL) (QUOTE EXTENSION) LAFITEDL.EXT)) STREAM) (if (NULL (SETQ FILENAME (if (OR (UNPACKFILENAME.STRING FILENAME (QUOTE HOST)) (UNPACKFILENAME.STRING FILENAME (QUOTE DIRECTORY))) then (INFILEP FILENAME) else (* ; "Search default directories") (FINDFILE FILENAME T (CONS LAFITEDEFAULTHOST&DIR LAFITEDLDIRECTORIES))))) then (LIST :ERROR "Can't find file by this name") elseif (NULL (SETQ STREAM (CAR (NLSETQ (OPENTEXTSTREAM (MKATOM FILENAME)))))) then (LIST :ERROR (CONCAT "Can't open " DL)) else (RESETLST (RESETSAVE NIL (LIST (QUOTE CLOSEF) STREAM)) (* ; "I hope this closes the file.  We used OPENTEXTSTREAM instead of OPEN so that file can contain tedit formatting.") (bind LINE SOME RESULT while (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) when (SETQ SOME (\GV.PARSERECIPIENTS1 LINE NIL INTERNALFLG EDITWINDOW T)) do (* ; "Note that we parse with respect to NO registry--require that the file contain all complete addresses") (if (EQ (CAR SOME) :ERROR) then (RETURN SOME) else (SETQ RESULT (NCONC SOME RESULT))) finally (* ; "Whole file parsed ok, so return the result") (RETURN RESULT))))))))
)

(\GV.PARSE.FAILED
(LAMBDA (ADDRESS) (* ; "Edited 13-Oct-87 14:17 by bvm:") (LIST :ERROR (CONCAT "Bad addressee " ADDRESS)))
)

(\LAFITE.CHOOSE.REPLYTO
(LAMBDA (TEXTSTREAM HEADEREOF FROMFIELD EDITORWINDOW) (* ; "Edited  3-Nov-89 12:59 by bvm") (* ;;; "Invoked when sending to a distribution list.  Ask user for Reply-to: field, and if one is chosen, enter it into message") (COND ((NULL EDITORWINDOW) T) (T (SELECTQ (\SENDMESSAGE.MENUPROMPT EDITORWINDOW (OR LAFITEREPLYTOMENU (SETQ LAFITEREPLYTOMENU (\LAFITE.CREATE.MENU LAFITEREPLYTOMENUITEMS "Include a Reply-to field?" T))) "Message is addressed to a distribution list" (QUOTE LAFITEREPLYTOMENU)) (NO T) (SELF (\LAFITE.INSERT.REPLYTO TEXTSTREAM (COND (FROMFIELD (* ; "Message explicitly from someone other than logged-in user, so set accordingly") (CONCATLIST (CDR (for GVNAME in FROMFIELD join (CONS ", " (COND ((EQ (CDR GVNAME) ARPANETGATEWAY.REGISTRY) (LIST (CAR GVNAME))) (T (LIST (CAR GVNAME) "." (CDR GVNAME))))))))) (T (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*))) NIL HEADEREOF) T) (OTHER (\LAFITE.INSERT.REPLYTO TEXTSTREAM ">>Address<<" T HEADEREOF) NIL) (ABORT NIL) NIL))))
)
)
(DEFINEQ

(\GV.MESSAGE.P
(LAMBDA (MSG) (* ; "Edited  6-May-88 13:58 by bvm") (* ;; "Test whether the specified message is a GV message.  We test for sender having gv format.  This may fail for msgs with malformed from, but that's too bad.") (LET* ((SENDER (fetch (LAFITEMSG FROM) of MSG)) (DOT (STRPOS "." SENDER))) (if (NULL DOT) then (* ; "No registry") NIL elseif (NULL (STRPOS ":" SENDER)) then (* ; "Registry and no colon, so believe it.  This is based on the assumption that all grapevine users are internal Xerox with only NS as competition.") T else (* ; "Subject it to the rigorous parser.") (NOT (FMEMB NIL (\GV.PARSERECIPIENTS1 SENDER))))))
)

(\GV.MESSAGE.FROM.SELF.P
(LAMBDA (MSG) (* ; "Edited  6-May-88 14:36 by bvm") (* ;; "True if message is from current user") (LET ((SENDER (fetch (LAFITEMSG FROM) of MSG)) (ME (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*)) HIT) (AND (SETQ HIT (STRPOS ME SENDER NIL NIL NIL NIL UPPERCASEARRAY)) (if (EQ (SETQ HIT (SUB1 HIT)) 0) then (* ; "Matched at start--is the length right?") (EQ (NCHARS ME) (NCHARS SENDER)) elseif (EQ (CL:CHAR SENDER (SUB1 HIT)) #\<) then (* ; "Also recognize %"name <realname>%"") (AND (< (add HIT (NCHARS ME)) (NCHARS SENDER)) (EQ (CL:CHAR SENDER HIT) #\>))))))
)

(GV.MAKEANSWERFORM
(LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* ; "Edited 10-Jun-88 17:27 by bvm") (LET ((MSGFIELDS (\LAFITE.PARSE.MESSAGE MAILFOLDER (OR (CAR (LISTP MSGDESCRIPTORS)) MSGDESCRIPTORS))) SUBJECT FROM DATE SENDER REPLYTO TO CC ORIGINALREGISTRY OLDFROM NEWTO NEWCC) (* ; "get the fields from the file") (for PAIR in MSGFIELDS do (SELECTQ (CAR PAIR) (Subject (SETQ SUBJECT (CADR PAIR))) (Sender (SETQ SENDER (CADR PAIR))) (From (SETQ FROM (CADR PAIR))) (Date (SETQ DATE (CADR PAIR))) (Reply-to (SETQ REPLYTO (CDR PAIR))) (To (SETQ TO (CDR PAIR))) (cc (SETQ CC (CDR PAIR))) NIL)) (* ;; "first parse the strings into recipients.  Need to find the sender's registry in order to get the registry defaults correct for its recipients.") (COND (SENDER (* ; "Sender is a mail address, and has the official registry") (SETQ OLDFROM (\GV.PARSERECIPIENTS SENDER NIL :BOTH)) (* ; "Elements are of the form (prettyname gvname . registry)") (if FROM then (* ; "Now that we have a source of official registry (we hope), parse the From field with reference to it.") (SETQ OLDFROM (\GV.PARSERECIPIENTS FROM (PROGN (* ; "Return first element that has a registry") (CL:SOME (QUOTE CDDR) OLDFROM)) :BOTH)))) (FROM (* ; "Have to parse the From field before we can get its registry") (SETQ OLDFROM (\GV.PARSERECIPIENTS FROM NIL :BOTH)))) (if (NULL OLDFROM) then (LAB.PROMPTPRINT MAILFOLDER T "Warning: message has no FROM field") else (SETQ ORIGINALREGISTRY (CL:SOME (QUOTE CDDR) OLDFROM)) (* ; "Choose first element that has a registry")) (AND TO (SETQ TO (\GV.PARSERECIPIENTS TO ORIGINALREGISTRY :BOTH))) (AND CC (SETQ CC (\GV.PARSERECIPIENTS CC ORIGINALREGISTRY :BOTH))) (SETQ NEWTO (OR (AND REPLYTO (SETQ REPLYTO (\GV.PARSERECIPIENTS REPLYTO ORIGINALREGISTRY :BOTH))) OLDFROM)) (SETQ NEWCC (\GV.DIFFERENCE (COND (REPLYTO (* ; "Reply goes only to this address, so the only cc is to self") (LIST (CONS (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*) (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*)))) (T (* ; "By default CC everyone who received the original message and to whom we are not directly replying already") (APPEND TO (\GV.DIFFERENCE CC TO)))) NEWTO)) (LAFITE.FILL.IN.ANSWER.FORM SUBJECT (if (AND (OR (NULL REPLYTO) (EQUAL REPLYTO OLDFROM)) (NULL (CDR NEWCC)) (OR (NULL NEWCC) (LET ((CC1 (CDAR NEWCC)) (CC2 (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) (AND (STRING-EQUAL (CAR CC1) (CAR CC2)) (STRING-EQUAL (CDR CC1) (CDR CC2)))))) then (* ; "Replying only to sender (and maybe self), so just say %"your%" instead of %"Joe Bob Smith <JBSmith.pa>'s%"") NIL else FROM) DATE NEWTO NEWCC (FUNCTION (LAMBDA (NAMES STREAM) (* ;; "Print all the pretty names") (LA.PRINT.COMMA.LIST (MAPCAR NAMES (FUNCTION CAR)) STREAM))))))
)

(\GV.DIFFERENCE
(LAMBDA (A B) (* ; "Edited  6-Jun-88 13:49 by bvm") (* ;; "Return all the names in A that aren't in B.  Names are of the form (prettyname gvname . registry).  We can't eliminate all gvname duplicates, since sometimes the prettyname contains more information (yecch).") (for TRIPLE in A collect TRIPLE unless (for OTHER in B bind (GVNAME _ (CADR TRIPLE)) thereis (AND (STRING-EQUAL (CADR OTHER) GVNAME) (OR (PROGN (* ; "Identical pretty names") (STRING-EQUAL (CAR OTHER) (CAR TRIPLE))) (PROGN (* ; "Identical gv names, and TRIPLE has no interesting additional info, like a people name") (AND (STRING-EQUAL (CDDR OTHER) (CDDR TRIPLE)) (STRING-EQUAL (CAR TRIPLE) (CONCAT (CADR TRIPLE) "." (CDDR TRIPLE))))))))))
)
)

(ADDTOVAR MAILSERVERTYPES )

(ADDTOVAR LAFITEDLDIRECTORIES )

(ADDTOVAR LAFITE.PERSONAL.VARS LAFITE.GV.FROM.FIELD)

(RPAQ? ARPANETGATEWAY.REGISTRY 'AG)

(RPAQ? LAFITEREPLYTOMENU NIL)

(RPAQ? LAFITEDL.EXT "DL")

(RPAQ? LAFITE.GV.FROM.FIELD )

(ADDTOVAR LAFITESUPPORT (GV "LafiteSupport.pa"))

(ADDTOVAR LAFITEMENUVARS LAFITEREPLYTOMENU)

(RPAQQ LAFITEREPLYTOMENUITEMS (("Send message as is" 'NO)
                                   ("Reply-to: me" 'SELF 
                                "Insert a Reply-to: field instructing responder to reply only to you"
                                          )
                                   ("Reply-to: other" 'OTHER 
                                          "Edit your own Reply-to: field into the message")
                                   ("Abort" 'ABORT "Don't send the message")))

(PUTPROPS MAINTAIN FILEDEF MAINTAIN)
(DECLARE%: DOEVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD MAILPORT (HOST# . SOCKET#))

(RECORD GVMAILPARSE (GVPSUBJECT GVPFROM GVPFORMAT . GVPRECIPIENTS))
)


(RPAQQ MAILCLIENTCONSTANTCOMS
       ((COMS                                                (* ; "Mail retrieval opcodes")
              (CONSTANTS (\OP.ADDRECIPIENT 21)
                     (\OP.ADDTOITEM 24)
                     (\OP.CHECKVALIDITY 22)
                     (\OP.HUMANMESS 520)
                     (\OP.MSEXPAND 27)
                     (\OP.SEND 26)
                     (\OP.STARTITEM 23)
                     (\OP.STARTSEND 20))
              (CONSTANTS (\MAILSOCKETTIMEOUT 36000000)))
        (COMS                                                (* ; "Mail sender opcodes")
              (CONSTANTS (\OP.OPENINBOX 0)
                     (\OP.NEXTMESSAGE 1)
                     (\OP.READTOC 2)
                     (\OP.READMESSAGE 3)
                     (\OP.WRITETOC 4)
                     (\OP.DELETEMESSAGE 5)
                     (\OP.FLUSH 6)))
        (COMS                                                (* ; 
                                                      "return codes from 'start to send a message'")
              (CONSTANTS (\RC.SENDSTARTED 0)
                     (\RC.PASSWORDINVALID 1)
                     (\RC.SENDERNOTREGISTERED 2)
                     (\RC.RETURNTONOTREGISTERED 3)
                     (\RC.COMMUNICATIONFAILURE 4)))
        (COMS                                                (* ; 
                                                           "return codes from 'open mail box'")
              (CONSTANTS (\RC.NAMEISGROUP 1)
                     (\RC.NAMEANDPASSWORDVALID 2)
                     (\RC.NAMENOTREGISTERED 3)
                     (\RC.COMMUNICATIONFAILURE 4)
                     (\RC.INVALIDPASSWORD 5)))
        (COMS                                                (* ; "Message Item types")
              (CONSTANTS (\I.POSTMARK 8)
                     (\I.SENDER 16)
                     (\I.RETURNTO 24)
                     (\I.RECIPIENTS 32)
                     (\I.TEXT 520)
                     (\I.OLDTEDITFORMATTING '(560 561))
                     (\I.TEDITFORMATTING 562)
                     (\I.END 65535)))
        (CONSTANTS (\PT.LAURELCHECK 140)
               (\PT.NOMAILBOX 139)
               (\PT.NONEWMAIL 138)
               (\PT.NEWMAIL 137))))



(* ; "Mail retrieval opcodes")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \OP.ADDRECIPIENT 21)

(RPAQQ \OP.ADDTOITEM 24)

(RPAQQ \OP.CHECKVALIDITY 22)

(RPAQQ \OP.HUMANMESS 520)

(RPAQQ \OP.MSEXPAND 27)

(RPAQQ \OP.SEND 26)

(RPAQQ \OP.STARTITEM 23)

(RPAQQ \OP.STARTSEND 20)


(CONSTANTS (\OP.ADDRECIPIENT 21)
       (\OP.ADDTOITEM 24)
       (\OP.CHECKVALIDITY 22)
       (\OP.HUMANMESS 520)
       (\OP.MSEXPAND 27)
       (\OP.SEND 26)
       (\OP.STARTITEM 23)
       (\OP.STARTSEND 20))
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \MAILSOCKETTIMEOUT 36000000)


(CONSTANTS (\MAILSOCKETTIMEOUT 36000000))
)



(* ; "Mail sender opcodes")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \OP.OPENINBOX 0)

(RPAQQ \OP.NEXTMESSAGE 1)

(RPAQQ \OP.READTOC 2)

(RPAQQ \OP.READMESSAGE 3)

(RPAQQ \OP.WRITETOC 4)

(RPAQQ \OP.DELETEMESSAGE 5)

(RPAQQ \OP.FLUSH 6)


(CONSTANTS (\OP.OPENINBOX 0)
       (\OP.NEXTMESSAGE 1)
       (\OP.READTOC 2)
       (\OP.READMESSAGE 3)
       (\OP.WRITETOC 4)
       (\OP.DELETEMESSAGE 5)
       (\OP.FLUSH 6))
)



(* ; "return codes from 'start to send a message'")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \RC.SENDSTARTED 0)

(RPAQQ \RC.PASSWORDINVALID 1)

(RPAQQ \RC.SENDERNOTREGISTERED 2)

(RPAQQ \RC.RETURNTONOTREGISTERED 3)

(RPAQQ \RC.COMMUNICATIONFAILURE 4)


(CONSTANTS (\RC.SENDSTARTED 0)
       (\RC.PASSWORDINVALID 1)
       (\RC.SENDERNOTREGISTERED 2)
       (\RC.RETURNTONOTREGISTERED 3)
       (\RC.COMMUNICATIONFAILURE 4))
)



(* ; "return codes from 'open mail box'")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \RC.NAMEISGROUP 1)

(RPAQQ \RC.NAMEANDPASSWORDVALID 2)

(RPAQQ \RC.NAMENOTREGISTERED 3)

(RPAQQ \RC.COMMUNICATIONFAILURE 4)

(RPAQQ \RC.INVALIDPASSWORD 5)


(CONSTANTS (\RC.NAMEISGROUP 1)
       (\RC.NAMEANDPASSWORDVALID 2)
       (\RC.NAMENOTREGISTERED 3)
       (\RC.COMMUNICATIONFAILURE 4)
       (\RC.INVALIDPASSWORD 5))
)



(* ; "Message Item types")

(DECLARE%: EVAL@COMPILE 

(RPAQQ \I.POSTMARK 8)

(RPAQQ \I.SENDER 16)

(RPAQQ \I.RETURNTO 24)

(RPAQQ \I.RECIPIENTS 32)

(RPAQQ \I.TEXT 520)

(RPAQQ \I.OLDTEDITFORMATTING (560 561))

(RPAQQ \I.TEDITFORMATTING 562)

(RPAQQ \I.END 65535)


(CONSTANTS (\I.POSTMARK 8)
       (\I.SENDER 16)
       (\I.RETURNTO 24)
       (\I.RECIPIENTS 32)
       (\I.TEXT 520)
       (\I.OLDTEDITFORMATTING '(560 561))
       (\I.TEDITFORMATTING 562)
       (\I.END 65535))
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \PT.LAURELCHECK 140)

(RPAQQ \PT.NOMAILBOX 139)

(RPAQQ \PT.NONEWMAIL 138)

(RPAQQ \PT.NEWMAIL 137)


(CONSTANTS (\PT.LAURELCHECK 140)
       (\PT.NOMAILBOX 139)
       (\PT.NONEWMAIL 138)
       (\PT.NEWMAIL 137))
)


(CL:PROCLAIM '(GLOBAL MAILSERVERTYPES ARPANETGATEWAY.REGISTRY LAFITEREPLYTOMENUITEMS 
                     LAFITEREPLYTOMENU))

(CL:PROCLAIM '(CL:SPECIAL *MSGOUTSTREAM*))


(FILESLOAD (SOURCE)
       LAFITEDECLS)


(FILESLOAD (LOADCOMP)
       GRAPEVINE PUP BSP)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(CL:PROCLAIM '(GLOBAL LAFITE.GV.FROM.FIELD LAFITEDL.EXT LAFITEDLDIRECTORIES))

(CL:PROCLAIM '(CL:SPECIAL *GV-SHOW-POSTMARK*))


(FILESLOAD GRAPEVINE)
)
(PUTPROPS MAILCLIENT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4636 7478 (GV.STARTSEND 4646 . 5324) (GV.ADDRECIPIENT 5326 . 5469) (GV.CHECKVALIDITY 
5471 . 5617) (GV.STARTITEM 5619 . 5820) (GV.ADDTOITEM 5822 . 7080) (GV.SEND 7082 . 7204) (MS.EXPAND 
7206 . 7476)) (7512 9991 (MS.SENDOPERATION 7522 . 8117) (\FINDMAILSERVER 8119 . 8472) (
\MAILSERVERSOCKETS 8474 . 8842) (\RECEIVEACK 8844 . 8999) (\RESPTOCHECKVAL 9001 . 9306) (\RESPTOEXPAND
 9308 . 9636) (\RESPTOSTARTSEND 9638 . 9989)) (10491 13022 (GV.PORTFROMNAME 10501 . 10648) (
GV.POLLNEWMAIL 10650 . 11462) (GV.OPENMAILBOX 11464 . 12116) (GV.NEXTMESSAGE 12118 . 12496) (
GV.RETRIEVEMESSAGE 12498 . 12739) (GV.CLOSEMAILBOX 12741 . 13020)) (13226 13684 (GV.READTOC 13236 . 
13375) (GV.WRITETOC 13377 . 13532) (GV.DELETEMESSAGE 13534 . 13682)) (13720 17357 (
MS.RETRIEVEOPERATION 13730 . 14190) (\CONNECTTOMAILSERVER 14192 . 14612) (\RESPTOOPENMAILBOX 14614 . 
14933) (\RESPTONEXTMESSAGE 14935 . 15087) (\RESPTORETRIEVEMESSAGE 15089 . 16896) (\RECEIVELONGWORD 
16898 . 17092) (\CACHED.HOST.NAME 17094 . 17355)) (17852 20265 (GV.INIT.MAIL.USER 17862 . 19562) (
GETMAILSERVEROPS 19564 . 20009) (\GV.MAILSERVERTYPE 20011 . 20263)) (20266 30747 (\GV.SENDMESSAGE 
20276 . 29910) (\GV.SENDRECIPIENTS 29912 . 30745)) (30748 43923 (\GV.SEND.PARSE 30758 . 32433) (
\GV.PARSERECIPIENTS 32435 . 32824) (\GV.PARSERECIPIENTS1 32826 . 38048) (\GV.FIND.NON.SPACE 38050 . 
38371) (\GV.PARSE.SIMPLE.RECIPIENT 38373 . 40254) (\GV.EXTRACT.FIELD 40256 . 41052) (\GV.HANDLE.DL 
41054 . 42758) (\GV.PARSE.FAILED 42760 . 42889) (\LAFITE.CHOOSE.REPLYTO 42891 . 43921)) (43924 48688 (
\GV.MESSAGE.P 43934 . 44581) (\GV.MESSAGE.FROM.SELF.P 44583 . 45186) (GV.MAKEANSWERFORM 45188 . 47954)
 (\GV.DIFFERENCE 47956 . 48686)))))
STOP
\ No newline at end of file
diff --git a/internal/library/MAILSCAVENGE b/internal/library/MAILSCAVENGE
new file mode 100644
index 00000000..95de1b1f
--- /dev/null
+++ b/internal/library/MAILSCAVENGE
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 18:25:37" {DSK}<usr>local>lde>lispcore>internal>library>MAILSCAVENGE.;2 21651  

      changes to%:  (VARS MAILSCAVENGECOMS)

      previous date%: " 7-Nov-89 19:34:02" 
{DSK}<usr>local>lde>lispcore>internal>library>MAILSCAVENGE.;1)


(* ; "
Copyright (c) 1985, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT MAILSCAVENGECOMS)

(RPAQQ MAILSCAVENGECOMS
       [(FNS LAFITE.SCAVENGE \MAILSCAVENGE.INTERNAL \MAILSCAVENGE.OPEN.SCRATCH 
             \MAILSCAVENGE.LENGTHWIDTH \MAILSCAVENGE.LFCOPYBYTES \MAILSCAVENGE.READSTAMP 
             \MAILSCAVENGE.DUPLICATE? \MAILSCAVENGE.FORMAT \MAILSCAVENGE.MAKEWINDOW 
             \MAILSCAVENGE.ASKUSER \MAILSCAVENGE.FIX.LENGTHS \MAILSCAVENGE.CONFIRM)
        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (*START*LENGTH 8))
               (SPECVARS *FOLDER* *ERRORMSGSTREAM* *EOL*)
               (LOCALVARS . T))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA 
                                                                                 \MAILSCAVENGE.FORMAT
                                                                                   ])
(DEFINEQ

(LAFITE.SCAVENGE
(LAMBDA (FOLDERNAME ERRORMSGSTREAM FORGET?) (* ; "Edited 18-Apr-89 18:19 by bvm") (* ;; "User entry to the scavenger.  If FORGET?, we won't add folder to the list of known folders.") (LET ((FOLDER (LAFITE.OBTAIN.FOLDER (LA.LONGFILENAME FOLDERNAME LAFITEMAIL.EXT) (QUOTE INPUT) T (AND FORGET? :FORGET)))) (WITH.MONITOR (fetch (MAILFOLDER FOLDERLOCK) of FOLDER) (\MAILSCAVENGE.INTERNAL FOLDER ERRORMSGSTREAM))))
)

(\MAILSCAVENGE.INTERNAL
(LAMBDA (*FOLDER* *ERRORMSGSTREAM* GOODPTR MSGNO) (* ; "Edited  3-May-89 13:05 by bvm") (* ;; "Scavenge FOLDER, which can be a mail folder, mail file name, or open stream on a mail file.  Commentary goes to *ERRORMSGSTREAM*, which for folders defaults to its browser window.  If GOODPTR is supplied, it is a file pointer that we assert points to the *START* corresponding to msg # MSGNO, and we guarantee we will not touch anything earlier in the file.") (LET (SCRATCHSTREAM FOLDERSTRM) (CL:UNWIND-PROTECT (PROG ((*UPPER-CASE-FILE-NAMES* NIL) (*PRINT-BASE* 10) (BADCOUNT 0) (*START* "*start*
") (*EOL* (CHARCODE CR)) (COPYFN (FUNCTION COPYBYTES)) TRYPTR LFP PWINDOW XPOS DUPSCRATCH FOLDERNAME EOFPTR BODYSTART BADHEADER NOMOREP STAMPLENGTH MSGLENGTH ENDPTR FIELDWIDTH LENGTHFIXUPS TRUNCATEPTR TSTREAM SUCCESS CH) (DECLARE (CL:SPECIAL *FOLDER* *ERRORMSGSTREAM* *EOL*)) (* ; "Used by \mailscavenge.askuser") (if (TYPENAMEP *FOLDER* (QUOTE MAILFOLDER)) then (* ; "It's a mail folder, so play by the rules") (SETQ FOLDERSTRM (\LAFITE.OPEN.FOLDER *FOLDER* (QUOTE INPUT) :OK)) (SETQ PWINDOW (fetch (MAILFOLDER BROWSERPROMPTWINDOW) of *FOLDER*)) elseif (TYPENAMEP *FOLDER* (QUOTE STREAM)) then (SETQ FOLDERSTRM *FOLDER*) else (SETQ FOLDERSTRM (\LAFITE.OPENSTREAM *FOLDER* (QUOTE INPUT) (QUOTE OLD) (FUNCTION \LAFITE.EOF) NIL (QUOTE LAFITE)))) (SETQ FOLDERNAME (FULLNAME FOLDERSTRM)) (SETFILEINFO FOLDERSTRM (QUOTE BUFFERS) 30) (SETQ EOFPTR (GETEOFPTR FOLDERSTRM)) (SETFILEPTR FOLDERSTRM 0) (if PWINDOW then (LAB.PROMPTPRINT *FOLDER* " Scavenging... ") (SETQ XPOS (DSPXPOSITION NIL PWINDOW))) (if (NOT *ERRORMSGSTREAM*) then (SETQ *ERRORMSGSTREAM* (if (AND (TYPENAMEP *FOLDER* (QUOTE MAILFOLDER)) (SETQ TSTREAM (\MAILSCAVENGE.MAKEWINDOW *FOLDER*))) then (* ; "We waited til here to make the window in case printing %"Scavenging... %" up there grew the window.") (TEXTSTREAM TSTREAM) else (GETSTREAM NIL (QUOTE OUTPUT))))) (\MAILSCAVENGE.FORMAT "Scavenging ~A..." FOLDERNAME) (if GOODPTR then (* ; "Somebody has already gotten us started") (GO LP) else (SETQ GOODPTR 0) (SETQ MSGNO 1) (if (LA.READSTAMP FOLDERSTRM) then (* ; "Good start") (GO PARSEMSG) elseif (PROGN (SETFILEPTR FOLDERSTRM (SUB1 *START*LENGTH)) (AND (EQ (BIN FOLDERSTRM) (CHARCODE LF)) (FILEPOS "*start*" FOLDERSTRM 0 7))) then (* ; "LF woes") (if (\MAILSCAVENGE.ASKUSER "File was apparently written with end of line convention LF.  Convert to CR (Note: TEdit formatting may be corrupted by this action, or could already have been corrupted by copying the file into LF format)? ") then (SETQ *START* "*start*") (SETQ COPYFN (FUNCTION \MAILSCAVENGE.LFCOPYBYTES)) (SETQ *EOL* (CHARCODE LF)) (SETQ LFP T) (SETQ SCRATCHSTREAM (\MAILSCAVENGE.OPEN.SCRATCH FOLDERNAME)) (SETFILEINFO FOLDERSTRM (QUOTE EOL) (QUOTE LF))) elseif (\MAILSCAVENGE.ASKUSER (CL:FORMAT NIL "Alleged mail folder ~A doesn't begin with a Lafite header -- proceed anyway? " FOLDERNAME)) then (SETQ BODYSTART 0) (GO FINDSTART) else (RETURN NIL))) LP (* ;; "GOODPTR is believed to point at *start*") (SETFILEPTR FOLDERSTRM GOODPTR) (if (NOT (\MAILSCAVENGE.READSTAMP FOLDERSTRM)) then (* ; "This shouldn't happen") (CL:ERROR "Scavenger is confused at message ~D, byte ~D" MSGNO GOODPTR)) PARSEMSG (if PWINDOW then (* ; "Tell which message we're on") (DSPXPOSITION XPOS PWINDOW) (PRIN3 MSGNO PWINDOW)) (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (if (NOT (AND (SETQ MSGLENGTH (LA.READCOUNT FOLDERSTRM)) (> MSGLENGTH 0))) then (* ; "Malformed header--not even the length exists.  Will need to build a new header.  Take all the stuff from BODYSTART as potential message") (SETQ BADHEADER T) (GO FINDSTART)) (SETQ BADHEADER (NOT (AND (PROGN (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (SETQ STAMPLENGTH (LA.READCOUNT FOLDERSTRM))) (PROGN (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) (BIN FOLDERSTRM) (BIN FOLDERSTRM) (BIN FOLDERSTRM) (* ; "Read 3 status bytes") (OR (EQ (SETQ CH (BIN FOLDERSTRM)) *EOL*) (AND LFP (EQ CH (CHARCODE CR))))) (<= (- (SETQ BODYSTART (GETFILEPTR FOLDERSTRM)) GOODPTR) STAMPLENGTH)))) (* ;; "We have a plausible length.  BADHEADER true means the rest of header does not parse because (a) no header length, (b) no CR after the the 3 mark bytes, or (c) header length is too short.  Wait to see whether the length appears correct before deciding whether to rebuild the header or just smash it.") (* ; "Take all the stuff from BODYSTART as potential message") (if (OR (<= (SETQ ENDPTR (+ GOODPTR MSGLENGTH)) (GETFILEPTR FOLDERSTRM)) (> ENDPTR EOFPTR)) then (* ; "Length too short or points past eof.") (GO FINDSTART) elseif (AND (< ENDPTR EOFPTR) (PROGN (SETFILEPTR FOLDERSTRM ENDPTR) (NOT (\MAILSCAVENGE.READSTAMP FOLDERSTRM)))) then (* ; "Length doesn't point at next *start*, have to search for a boundary") (SETFILEPTR FOLDERSTRM ENDPTR) (if (AND (EQ (BIN FOLDERSTRM) 0) (to (- EOFPTR ENDPTR 1) always (EQ (BIN FOLDERSTRM) 0))) then (* ; "File is well-formed except for ending in a bunch of nulls.  This seems to happen every once in a fhile when a file server spazzes.  Throw them away.") (\MAILSCAVENGE.FORMAT "~%%Starting at byte ~D (after message #~D):~%%    File ends in ~D null bytes.  Will discard." ENDPTR MSGNO (- EOFPTR ENDPTR)) (if SCRATCHSTREAM then (* ; "Copy last message verbatim to scratch file") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM GOODPTR ENDPTR) else (* ; "Note truncation here") (SETQ TRUNCATEPTR ENDPTR)) (add BADCOUNT 1) (GO DONE)) (GO FINDSTART) elseif BADHEADER then (* ; "Length ok, but header was malformed.  It is likely to be safe to just overwrite the header") (add BADCOUNT 1) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D: length ok, but header garbled." MSGNO GOODPTR) (SETQ FIELDWIDTH (\MAILSCAVENGE.LENGTHWIDTH FOLDERSTRM GOODPTR)) (if SCRATCHSTREAM then (* ; "Have to copy") (SETQ BODYSTART (+ GOODPTR FIELDWIDTH LAFITEBASICSTAMPLENGTH)) (SETQ MSGLENGTH (- ENDPTR BODYSTART)) (GO COPYMSG) else (* ; "Remember fixup") (push LENGTHFIXUPS (LIST GOODPTR MSGLENGTH FIELDWIDTH T)) (GO NEXT)) else (* ; "Well-formed message") (if (AND (< (- BODYSTART GOODPTR) STAMPLENGTH) (EQ (PROGN (SETFILEPTR FOLDERSTRM BODYSTART) (BIN FOLDERSTRM)) (CHARCODE *))) then (* ; "May be a funny one") (LET ((INFO (CL:READ-LINE FOLDERSTRM)) ISDUP) (if (AND (STRPOS "duplicate*" INFO 1 NIL T) (FIXP (SETQ INFO (SUBATOM INFO 11)))) then (* ; "This message claims to be a duplicate of the one at INFO") (SETQ ISDUP (\MAILSCAVENGE.DUPLICATE? FOLDERSTRM INFO GOODPTR STAMPLENGTH MSGLENGTH (OR DUPSCRATCH (SETQ DUPSCRATCH (OPENSTREAM "{nodircore}" (QUOTE BOTH)))))) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D is marked as a duplicate of the one at byte~D from an aborted Expunge~A." MSGNO GOODPTR INFO (if (NOT ISDUP) then "; however, the original is not there" elseif SCRATCHSTREAM then " (not copied)" else "")) (if ISDUP then (* ; "Nothing to do.") (GO NEXT) elseif SCRATCHSTREAM then (SETQ BADHEADER T) (* ; "so that message gets undeleted") (GO COPYGOOD) else (* ; "Want to rewrite the flags") (push LENGTHFIXUPS (LIST GOODPTR NIL NIL T)) (GO NEXT))))) (if SCRATCHSTREAM then (* ; "Copy verbatim to scratch file") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM GOODPTR ENDPTR)) (GO NEXT)) FINDSTART (* ;; "At this point, we have a malformed message starting at GOODPTR.  Look for its end.  If the header is also malformed, BADHEADER is true.  BODYSTART points at what could be the start of text..") (SETQ TRYPTR BODYSTART) FINDSTARTLP (SETQ ENDPTR (FFILEPOS *START* FOLDERSTRM TRYPTR)) (if (NULL ENDPTR) then (* ; "Can't find next message.  Maybe this is the last one") (if (AND (EQ MSGNO 1) BADHEADER) then (* ; "Never saw a single *start*") (if (NULL (\MAILSCAVENGE.ASKUSER (CL:FORMAT NIL "There are no message boundaries in this file.  Do you want to turn the file into a single message of length ~D?" (- EOFPTR GOODPTR)))) then (RETURN NIL))) (SETQ ENDPTR EOFPTR) elseif (AND LFP (PROGN (* ; "Have to check that an eol follows, since we're not sure which kind.") (SETFILEPTR FOLDERSTRM (+ ENDPTR (SUB1 *START*LENGTH))) (SELCHARQ (BIN FOLDERSTRM) ((CR LF) NIL) T))) then (SETQ TRYPTR (+ ENDPTR (- *START*LENGTH 2))) (GO FINDSTARTLP)) (\MAILSCAVENGE.FORMAT "~%%Message #~D at byte ~D: length ~:[missing~%%    (~;incorrect~%%    (file says ~:*~D, ~]apparent length is ~D)" MSGNO GOODPTR MSGLENGTH (if BADHEADER then (* ; "Estimate based on standard header size.  We'll be exact later") (+ LAFITESTAMPLENGTH (SETQ MSGLENGTH (- ENDPTR BODYSTART))) else (SETQ MSGLENGTH (- ENDPTR GOODPTR)))) (add BADCOUNT 1) (if BADHEADER then (\MAILSCAVENGE.FORMAT "~%%    Need to rebuild internal header.  Message body may be malformed.") (GO COPYMSG)) (* ; "Header ok, just the length was wrong") (if (NULL SCRATCHSTREAM) then (* ; "Should suffice just to change length in place") (if (<= (NCHARS MSGLENGTH) (SETQ FIELDWIDTH (\MAILSCAVENGE.LENGTHWIDTH FOLDERSTRM GOODPTR))) then (* ; "Good, the correct length fits in the available space.  Save for confirmation later") (push LENGTHFIXUPS (LIST GOODPTR MSGLENGTH FIELDWIDTH)) (GO NEXT)) (* ;; "Arrrgh, the length is too big.  Fall thru to copy message to scratch file.") (\MAILSCAVENGE.FORMAT "~%%New length does not fit into old header, will have to rebuild.")) COPYGOOD (* ;; "Bring MSGLENGTH down to just the body length so we compute the new header correctly") (SETQ MSGLENGTH (- MSGLENGTH STAMPLENGTH)) COPYMSG (* ;; "At this point, we want to write the current message on scratch file.  MSGLENGTH is the length of the body, sans header, starting at BODYSTART.  If BADHEADER is true, we rebuild whole header.  Otherwise, message is believed well-formed, so we can copy flag bytes from old message.") (if (NULL SCRATCHSTREAM) then (* ; "Have to set up scratch file") (\MAILSCAVENGE.FORMAT "~%%Opening scratch file to handle rebuilt header.") (SETQ SCRATCHSTREAM (\MAILSCAVENGE.OPEN.SCRATCH FOLDERNAME)) (if (> GOODPTR 0) then (\MAILSCAVENGE.FORMAT "~%%Copying ~D previous message~:P to scratch file..." (SUB1 MSGNO)) (COPYBYTES FOLDERSTRM SCRATCHSTREAM 0 GOODPTR) (\MAILSCAVENGE.FORMAT "done."))) (LA.PRINTHEADER SCRATCHSTREAM MSGLENGTH) (if BADHEADER then (* ; "Have to create afresh, so use primordial flags") (PRIN3 "UU 
" SCRATCHSTREAM) else (* ; "Original header was ok, except for length info, so copy flags and mark byte from it.") (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM (- BODYSTART 4) BODYSTART) (SETQ BODYSTART (+ GOODPTR STAMPLENGTH))) (CL:FUNCALL COPYFN FOLDERSTRM SCRATCHSTREAM BODYSTART ENDPTR) NEXT (COND ((< (SETQ GOODPTR ENDPTR) EOFPTR) (* ; "Go process some more") (add MSGNO 1) (GO LP))) DONE (* ;; "All finished--shall we confirm it?") (if SCRATCHSTREAM then (* ; "Close this now (could be slow) before saying done.") (SETQ SCRATCHSTREAM (CLOSEF SCRATCHSTREAM))) (if PWINDOW then (DSPXPOSITION XPOS PWINDOW) (PRIN1 "done. " PWINDOW)) (SETQ SUCCESS (if SCRATCHSTREAM then (* ; "We had to use a scratch file.") (if LENGTHFIXUPS then (* ; "Had some length fixups before we got to a really bad spot, so go back and do them now") (SETQ SCRATCHSTREAM (OPENSTREAM SCRATCHSTREAM (QUOTE BOTH) (QUOTE OLD) (QUOTE ((TYPE LAFITE))))) (CL:UNWIND-PROTECT (\MAILSCAVENGE.FIX.LENGTHS LENGTHFIXUPS SCRATCHSTREAM) (SETQ SCRATCHSTREAM (CLOSEF SCRATCHSTREAM)))) (if (AND (\MAILSCAVENGE.CONFIRM BADCOUNT MSGNO "Replace damaged mail file with scavenged file? ") (PROGN (if *FOLDER* then (\LAFITE.CLOSE.FOLDER *FOLDER* T) else (CLOSEF FOLDERSTRM)) (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (\LAFITE.RENAMEFILE SCRATCHSTREAM FOLDERNAME) (if RESULT then T else (\MAILSCAVENGE.FORMAT "~%%RenameFile failed~@[ because ~A~]." CONDITION) NIL)))) then T else (* ; "File not renamed, either because of error or user choice.  Tell where the scavenged file is.") (\MAILSCAVENGE.FORMAT "~%%Scavenged file stored as ~A." SCRATCHSTREAM MSGNO) NIL) elseif (AND (NULL LENGTHFIXUPS) (NULL TRUNCATEPTR)) then (\MAILSCAVENGE.FORMAT "~%%~A is a well-formed message file of ~D messages." FOLDERNAME MSGNO) NIL elseif (\MAILSCAVENGE.CONFIRM BADCOUNT MSGNO "Shall I correct these messages in the file? ") then (* ; "Do fixups in place") (if *FOLDER* then (SETQ FOLDERSTRM (\LAFITE.OPEN.FOLDER *FOLDER* (QUOTE BOTH))) elseif (NOT (OPENP FOLDERSTRM (QUOTE OUTPUT))) then (SETQ FOLDERSTRM (OPENSTREAM (CLOSEF FOLDERSTRM) (QUOTE BOTH) NIL (QUOTE ((TYPE LAFITE)))))) (\MAILSCAVENGE.FIX.LENGTHS LENGTHFIXUPS FOLDERSTRM) (if TRUNCATEPTR then (* ; "Truncate file to drop nulls off end") (SETFILEINFO FOLDERSTRM (QUOTE LENGTH) TRUNCATEPTR)) (* ; "Return success") T)) (if SUCCESS then (\MAILSCAVENGE.FORMAT "done.~2%%You may want to examine the messages listed above for duplications or concatenated messages.~%%")) (if TSTREAM then (DETACHWINDOW TSTREAM) (\MAILSCAVENGE.FORMAT "
(This report window is now detached from its browser.
 You may close it at your convenience.)")) (RETURN (AND SUCCESS FOLDERNAME))) (* ;; "Cleanup time") (if (type? MAILFOLDER *FOLDER*) then (\LAFITE.CLOSE.FOLDER *FOLDER* T) elseif (AND (STREAMP FOLDERSTRM) (OPENP FOLDERSTRM)) then (CLOSEF FOLDERSTRM)) (if (STREAMP SCRATCHSTREAM) then (* ; "Must have aborted.") (DELFILE (CLOSEF SCRATCHSTREAM))))))
)

(\MAILSCAVENGE.OPEN.SCRATCH
(LAMBDA (FOLDERNAME) (* ; "Edited  3-May-89 13:03 by bvm") (OPENSTREAM (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) (CONCAT (UNPACKFILENAME.STRING FOLDERNAME (QUOTE EXTENSION)) "-scavenged") (QUOTE BODY) FOLDERNAME) (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE LAFITE) (SEQUENTIAL T)))))
)

(\MAILSCAVENGE.LENGTHWIDTH
(LAMBDA (FOLDERSTRM STARTPTR) (* ; "Edited  3-May-89 12:42 by bvm") (* ;; "Return the actual width of the %"message length%" field in this message") (LET ((LENSTART (+ STARTPTR *START*LENGTH))) (SETFILEPTR FOLDERSTRM LENSTART) (LA.READCOUNT FOLDERSTRM T) (- (GETFILEPTR FOLDERSTRM) LENSTART 1)))
)

(\MAILSCAVENGE.LFCOPYBYTES
(LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited  3-May-89 13:07 by bvm") (* ;; "A COPYBYTES that turns LF into CR as it goes.") (SETFILEPTR SRCFIL START) (to (- END START) bind CH do (\BOUT DSTFIL (if (EQ (SETQ CH (BIN SRCFIL)) (CHARCODE LF)) then (CHARCODE CR) else CH))))
)

(\MAILSCAVENGE.READSTAMP
(LAMBDA (STREAM) (* ; "Edited  3-May-89 12:20 by bvm") (* ;; "Like LA.READSTAMP, but also succeeds if the stamp ends in LF when we're processing a LF file.") (AND (EQ (BIN STREAM) (CHARCODE *)) (EQ (BIN STREAM) (CHARCODE s)) (EQ (BIN STREAM) (CHARCODE t)) (EQ (BIN STREAM) (CHARCODE a)) (EQ (BIN STREAM) (CHARCODE r)) (EQ (BIN STREAM) (CHARCODE t)) (EQ (BIN STREAM) (CHARCODE *)) (SELCHARQ (BIN STREAM) (CR T) (LF (EQ *EOL* (CHARCODE LF))) NIL)))
)

(\MAILSCAVENGE.DUPLICATE?
(LAMBDA (FOLDERSTRM OLDPTR GOODPTR STAMPLENGTH MSGLENGTH SCRATCH) (* ; "Edited  2-May-89 12:06 by bvm") (* ;; "True if the message at pointer OLDPTR is a duplicate of the one starting at GOODPTR with lengths STAMPLENGTH & MSGLENGTH.") (SETFILEPTR FOLDERSTRM OLDPTR) (LET (OLDLENGTH OLDSTAMP) (AND (LA.READSTAMP FOLDERSTRM) (SETQ OLDLENGTH (LA.READCOUNT FOLDERSTRM)) (SETQ OLDSTAMP (LA.READCOUNT FOLDERSTRM)) (\LAFITE.CHECK.DUPLICATE FOLDERSTRM SCRATCH GOODPTR STAMPLENGTH MSGLENGTH OLDPTR OLDSTAMP OLDLENGTH))))
)

(\MAILSCAVENGE.FORMAT
(CL:LAMBDA (&REST ARGS) (* ; "Edited 21-Apr-89 15:25 by bvm") (if (TEXTSTREAMP *ERRORMSGSTREAM*) then (* ;; "It is MUCH faster to cons the string and hand it to tedit than to print a character at a time.  One difference: unless we set the %"dontscroll%" flag, the window will scroll when we run off the bottom.  This is probably desirable, as it means we look like we're doing something.") (TEDIT.INSERT *ERRORMSGSTREAM* (CL:APPLY (FUNCTION CL:FORMAT) NIL ARGS) (ADD1 (GETEOFPTR *ERRORMSGSTREAM*))) else (CL:APPLY (FUNCTION CL:FORMAT) *ERRORMSGSTREAM* ARGS)))
)

(\MAILSCAVENGE.MAKEWINDOW
(LAMBDA (FOLDER) (* ; "Edited 21-Apr-89 15:34 by bvm") (* ;; "Return a tedit window to use for Scavenger report, or NIL if FOLDER doesn't have a browser") (LET ((BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (if BROWSERWINDOW then (LET* ((FONT (DSPFONT NIL (fetch (MAILFOLDER BROWSERWINDOW) of FOLDER))) (ERRHEIGHT (HEIGHTIFWINDOW (TIMES 10 (FONTPROP FONT (QUOTE HEIGHT))) T)) (ERRW (CREATEW (CREATEREGION 0 0 10 ERRHEIGHT) (CONCAT "Mail Scavenger Report for " (fetch (MAILFOLDER SHORTFOLDERNAME) of FOLDER)) T))) (ATTACHWINDOW ERRW BROWSERWINDOW (if (< (fetch (REGION BOTTOM) of (WINDOWPROP BROWSERWINDOW (QUOTE REGION))) ERRHEIGHT) then (* ; "Won't fit below") (QUOTE TOP) else (QUOTE BOTTOM)) (QUOTE JUSTIFY) (QUOTE LOCALCLOSE)) (OPENTEXTSTREAM "" ERRW NIL NIL (BQUOTE (FONT (\, FONT) PROMPTWINDOW DON'T))) ERRW))))
)

(\MAILSCAVENGE.ASKUSER
(LAMBDA (PROMPT) (DECLARE (CL:SPECIAL *FOLDER*)) (* ; "Edited  2-May-89 11:42 by bvm") (LET (BROWSERWINDOW) (if (AND *FOLDER* (SETQ BROWSERWINDOW (fetch (MAILFOLDER BROWSERWINDOW) of *FOLDER*))) then (* ; "Use the browser for interaction") (CLEARW BROWSERWINDOW) (FLASHWINDOW BROWSERWINDOW) (if (> (STRINGWIDTH PROMPT BROWSERWINDOW) (WINDOWPROP BROWSERWINDOW (QUOTE WIDTH))) then (* ; "Sigh, too wide to centerprint.  I wish we had better text layout...") (RELMOVETO 0 (- (IQUOTIENT (WINDOWPROP BROWSERWINDOW (QUOTE HEIGHT)) 2)) BROWSERWINDOW) (PRIN3 PROMPT BROWSERWINDOW) else (* ; "Nicely center the prompt") (CENTERPRINTINREGION PROMPT NIL BROWSERWINDOW)) (LET* ((MENUW (fetch (MAILFOLDER BROWSERMENUWINDOW) of *FOLDER*)) (MENUWREG (WINDOWPROP MENUW (QUOTE REGION))) (MENUWIDTH (fetch (REGION WIDTH) of MENUWREG)) (ITEMS (QUOTE (("Proceed" T "Continue the scavenge as asked") ("Abort" NIL "Abort the mail scavenge operation")))) (MENU (create MENU ITEMS _ ITEMS CENTERFLG _ T MENUFONT _ LAFITEMENUFONT MENUROWS _ 1 ITEMWIDTH _ (MAX (STRINGWIDTH (CAAR ITEMS) LAFITEMENUFONT) (IQUOTIENT MENUWIDTH 4)) MENUOUTLINESIZE _ 0 MENUBORDERSIZE _ 0))) (* ; "Position the menu in the middle of the browser's menu window") (PROG1 (MENU MENU (LA.POSITION.FROM.REGION MENUWREG (IQUOTIENT (- MENUWIDTH (fetch (MENU IMAGEWIDTH) of MENU)) 2) (WINDOWPROP MENUW (QUOTE BORDER))) T) (CLEARW BROWSERWINDOW))) else (EQ (ASKUSER NIL NIL PROMPT) (QUOTE Y)))))
)

(\MAILSCAVENGE.FIX.LENGTHS
(LAMBDA (FIXUPS STREAM) (* ; "Edited  3-May-89 12:42 by bvm") (* ;; "Perform length fixups.  FIXUPS has entries of the form (startptr length fieldwidth fixheader)") (for ENTRY in FIXUPS do (DESTRUCTURING-BIND (START LENGTH FIELDWIDTH FIXHEADER) ENTRY (SETFILEPTR STREAM (+ START *START*LENGTH)) (if LENGTH then (LA.PRINTCOUNT LENGTH STREAM (BQUOTE (FIX (\, FIELDWIDTH) 10 T))) else (LA.READCOUNT STREAM)) (if FIXHEADER then (* ; "Write the rest of the header, too") (if LENGTH then (LA.PRINTCOUNT (+ FIELDWIDTH LAFITEBASICSTAMPLENGTH) STREAM) else (LA.READCOUNT STREAM)) (PRIN3 "UU 
" STREAM))))))

(\MAILSCAVENGE.CONFIRM
(LAMBDA (BADNO TOTALNO PROMPT) (* ; "Edited 21-Apr-89 15:27 by bvm") (DECLARE (CL:SPECIAL *FOLDER* *ERRORMSGSTREAM*)) (* ;; "Called at end of scavenge to report results.  Return T/NIL response to PROMPT") (LET ((FORMATSTRING "~2%%Finished, found ~D bad messages out of ~D total messages.~%%")) (\MAILSCAVENGE.FORMAT FORMATSTRING BADNO TOTALNO) (if (\MAILSCAVENGE.ASKUSER PROMPT) then (if *FOLDER* then (* ; "Make sure to delete any toc that might be hanging around") (DELFILE (TOCFILENAME (fetch (MAILFOLDER FULLFOLDERNAME) of *FOLDER*)))) (\MAILSCAVENGE.FORMAT "Working... ") (* ; "Show some response") T)))
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ *START*LENGTH 8)


(CONSTANTS (*START*LENGTH 8))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(SPECVARS *FOLDER* *ERRORMSGSTREAM* *EOL*)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA \MAILSCAVENGE.FORMAT)
)
(PUTPROPS MAILSCAVENGE COPYRIGHT ("Venue & Xerox Corporation" 1985 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1429 21135 (LAFITE.SCAVENGE 1439 . 1871) (\MAILSCAVENGE.INTERNAL 1873 . 14946) (
\MAILSCAVENGE.OPEN.SCRATCH 14948 . 15279) (\MAILSCAVENGE.LENGTHWIDTH 15281 . 15609) (
\MAILSCAVENGE.LFCOPYBYTES 15611 . 15916) (\MAILSCAVENGE.READSTAMP 15918 . 16395) (
\MAILSCAVENGE.DUPLICATE? 16397 . 16940) (\MAILSCAVENGE.FORMAT 16942 . 17529) (\MAILSCAVENGE.MAKEWINDOW
 17531 . 18396) (\MAILSCAVENGE.ASKUSER 18398 . 19864) (\MAILSCAVENGE.FIX.LENGTHS 19866 . 20494) (
\MAILSCAVENGE.CONFIRM 20496 . 21133)))))
STOP
\ No newline at end of file
diff --git a/internal/library/MAILSCAVENGE.TEDIT b/internal/library/MAILSCAVENGE.TEDIT
new file mode 100644
index 00000000..83af75a4
Binary files /dev/null and b/internal/library/MAILSCAVENGE.TEDIT differ
diff --git a/internal/library/MAINTAIN b/internal/library/MAINTAIN
new file mode 100644
index 00000000..f2a860b4
--- /dev/null
+++ b/internal/library/MAINTAIN
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 18:32:50" {DSK}<usr>local>lde>lispcore>internal>library>MAINTAIN.;2 21701  

      changes to%:  (VARS MAINTAINCOMS)
                    (FNS \MT.PRINTSTRINGLIST)

      previous date%: "20-Jul-85 18:04:41" {DSK}<usr>local>lde>lispcore>internal>library>MAINTAIN.;1
)


(* ; "
Copyright (c) 1983, 1984, 1985, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT MAINTAINCOMS)

(RPAQQ MAINTAINCOMS
       ((FNS MAINTAIN \GETMAINTAINCOMMAND)
        (FNS \MT.ADD.FRIEND \MT.ADD.MEMBER \MT.ADD.OWNER \MT.CHANGE.PASSWORD \MT.CHANGE.REMARK 
             \MT.CHANGE.GROUP.COMPONENT \MT.LIST.GROUPS \MT.LOGIN \MT.REMOVE.FRIEND \MT.REMOVE.MEMBER
             \MT.REMOVE.OWNER \MT.TYPE.ENTRY \MT.TYPE.MEMBERS)
        (FNS \MT.MAYBE.PRINT.OVERSTAMPED.RLIST \MT.MAYBE.PRINT.STRING \MT.PRINTRLIST 
             \MT.PRINTSTRINGLIST \SKIPCOMPONENT \MT.SKIPSTRINGLIST \MT.RECEIVE.ENTRY)
        (FNS \MT.READRNAME \MT.PERMIT.NS)
        (VARS \MT.ELLIPSIS)
        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS * GVNAMETYPES)
               (MACROS .ELLIPSIS.)
               (GLOBALVARS \MT.ELLIPSIS))
        (FILES GRAPEVINE)))
(DEFINEQ

(MAINTAIN
  [LAMBDA NIL                                            (* bvm%: "20-Jul-85 17:58")
    (PROG (GVUSERNAME GVPASSWORD GVGROUPS LASTNAME LASTGROUP LASTSTRING RNAMEDELIMITERS)
          (DECLARE (SPECVARS GVUSERNAME GVPASSWORD GVGROUPS LASTNAME LASTGROUP LASTSTRING))
          (\MT.LOGIN T)
          (repeatwhile (NULL (ERSETQ (bind CMD while (SETQ CMD (\GETMAINTAINCOMMAND))
                                            do (APPLY* CMD])

(\GETMAINTAINCOMMAND
  [LAMBDA NIL                                            (* bvm%: "20-Jul-85 17:56")
    (TERPRI T)                                               (* Unimplemented commands%:
                                                           ("List All Groups" "" RETURN
                                                           (FUNCTION \MT.LIST.GROUPS)))
    (ASKUSER NIL NIL "GV: " '[("Add Friend" "" RETURN (FUNCTION \MT.ADD.FRIEND))
                              ("Add Member" "" RETURN (FUNCTION \MT.ADD.MEMBER))
                              ("Add Owner" "" RETURN (FUNCTION \MT.ADD.OWNER))
                              ("Change Password" "" RETURN (FUNCTION \MT.CHANGE.PASSWORD))
                              ("Change Remark" "" RETURN (FUNCTION \MT.CHANGE.REMARK))
                              ("Login" "" RETURN (FUNCTION \MT.LOGIN))
                              ("Quit" " [confirm]" CONFIRMFLG T RETURN NIL)
                              ("Permit Pseudo-NS names (must type CR to terminate names) [confirm]"
                               "" CONFIRMFLG T RETURN (FUNCTION \MT.PERMIT.NS))
                              ("Remove Friend" "" RETURN (FUNCTION \MT.REMOVE.FRIEND))
                              ("Remove Member" "" RETURN (FUNCTION \MT.REMOVE.MEMBER))
                              ("Remove Owner" "" RETURN (FUNCTION \MT.REMOVE.OWNER))
                              ("Type Entry" "" RETURN (FUNCTION \MT.TYPE.ENTRY))
                              ("Type Members" "" RETURN (FUNCTION \MT.TYPE.MEMBERS))
                              (% "^Y - Enter Lisp" NOECHOFLG T RETURN (FUNCTION (LAMBDA NIL
                                                                                   (TERPRI T)
                                                                                   (USEREXEC
                                                                                    '__]
           T NIL '(AUTOCOMPLETEFLG T])
)
(DEFINEQ

(\MT.ADD.FRIEND
  [LAMBDA NIL                                            (* bvm%: "17-SEP-83 14:16")
    (\MT.CHANGE.GROUP.COMPONENT (FUNCTION GV.ADDFRIEND)
           'ADD])

(\MT.ADD.MEMBER
  [LAMBDA NIL                                            (* bvm%: "17-SEP-83 14:16")
    (\MT.CHANGE.GROUP.COMPONENT (FUNCTION GV.ADDMEMBER)
           'ADD])

(\MT.ADD.OWNER
  [LAMBDA NIL                                            (* bvm%: "26-Apr-84 10:44")
    (\MT.CHANGE.GROUP.COMPONENT (FUNCTION GV.ADDOWNER)
           'ADD])

(\MT.CHANGE.PASSWORD
  [LAMBDA NIL                                            (* bvm%: "17-NOV-83 14:45")
    (PROG (NAME UPNAME PASS PASSKEY RESULT)
          (DECLARE (USEDFREE GVUSERNAME GVPASSWORD LASTNAME LASTSTRING))
          (COND
             ([SETQ NAME (\MT.READRNAME " for individual: " (CONCAT (CAR GVUSERNAME)
                                                                       "."
                                                                       (CDR GVUSERNAME]
              (COND
                 ([OR [NULL (SETQ PASS (PROMPTFORWORD " to be: " NIL NIL T '*]
                      (NOT (STREQUAL PASS (PROMPTFORWORD " (retype password) " NIL NIL T '*]
                  (printout T " xxx" T))
                 (T (.ELLIPSIS.)
                    (COND
                       ((EQ (SETQ RESULT (GV.CHANGEPASSWORD (SETQ UPNAME (\CHECKNAME NAME))
                                                (SETQ PASSKEY (GV.MAKEKEY PASS T))
                                                GVUSERNAME GVPASSWORD))
                            T)
                        (printout T " done" T)
                        (SETQ GVUSERNAME UPNAME)
                        (SETQ GVPASSWORD PASSKEY)
                        (SETPASSWORD 'GV (MKATOM (SETQ LASTNAME (SETQ LASTSTRING NAME)))
                               PASS))
                       (T (printout T RESULT])

(\MT.CHANGE.REMARK
  [LAMBDA NIL                                            (* bvm%: "17-SEP-83 15:23")
    (PROG (GVNAMETYPE GROUP RESULT NEWREMARK)
          (DECLARE (SPECVARS GVNAMETYPE)
                 (USEDFREE LASTGROUP LASTSTRING GVUSERNAME GVPASSWORD))
          (COND
             ((SETQ GROUP (\MT.READRNAME " for group: " LASTGROUP))
              (.ELLIPSIS.)
              [COND
                 ((STRINGP (SETQ RESULT (GV.READREMARK GROUP)))
                  (printout T " to be (type remark, terminate with <cr>)" T)
                  (COND
                     ([SETQ NEWREMARK (PROMPTFORWORD "Remark: " RESULT NIL T NIL NIL (CHARCODE (CR]
                      (.ELLIPSIS.)
                      (SETQ RESULT (GV.CHANGEREMARK GROUP NEWREMARK GVUSERNAME GVPASSWORD)))
                     (T (RETURN]
              (printout T (COND
                             ((EQ RESULT T)
                              "done")
                             (T RESULT))
                     T)
              (SETQ LASTSTRING (SETQ LASTGROUP GROUP])

(\MT.CHANGE.GROUP.COMPONENT
  [LAMBDA (GVACCESSFN OPERATION)                         (* bvm%: "16-SEP-83 23:05")
    (PROG (GVNAMETYPE GROUP INDIVIDUAL RESULT)
          (DECLARE (SPECVARS GVNAMETYPE)
                 (USEDFREE LASTNAME LASTGROUP LASTSTRING GVUSERNAME GVPASSWORD))
          (COND
             ((AND (SETQ INDIVIDUAL (\MT.READRNAME " name: " LASTNAME))
                   (SETQ GROUP (\MT.READRNAME (SELECTQ OPERATION
                                                      (ADD " to group: ")
                                                      (REMOVE " from group: ")
                                                      (SHOULDNT))
                                      LASTGROUP)))
              (.ELLIPSIS.)
              (SETQ RESULT (APPLY* GVACCESSFN GROUP INDIVIDUAL GVUSERNAME GVPASSWORD))
              (printout T (COND
                             ((EQ RESULT T)
                              "done")
                             (T RESULT))
                     T)
              (SETQ LASTNAME INDIVIDUAL)
              (SETQ LASTSTRING (SETQ LASTGROUP GROUP])

(\MT.LIST.GROUPS
  [LAMBDA NIL                                            (* bvm%: "17-SEP-83 15:52")
    (PROG (GVNAMETYPE NAME GROUPS REG FOUNDONE)
          (DECLARE (SPECVARS GVNAMETYPE)
                 (USEDFREE LASTNAME LASTGROUP LASTSTRING GVGROUPS))
          (COND
             ((AND (SETQ REG (PROMPTFORWORD " in registry: " DEFAULTREGISTRY))
                   (SETQ NAME (\MT.READRNAME " that contain the name: " LASTNAME)))
              (printout T " ... enumerating groups")
              (COND
                 ((EQ (SETQ GROUPS (GV.READMEMBERS (CONS 'GROUPS (MKATOM REG))
                                          (CAR GVGROUPS)))
                      'NoChange)
                  (SETQ GROUPS GVGROUPS))
                 (T (SETQ GVGROUPS GROUPS)))
              (printout T " done." T)
              (for GROUP in (CDR GROUPS) when (GV.ISMEMBERCLOSURE GROUP NAME)
                 do (COND
                           (FOUNDONE (printout T ", "))
                           (T (SETQ FOUNDONE T)))
                       (PRIN1 GROUP T))
              (SETQ LASTSTRING (SETQ LASTNAME NAME])

(\MT.LOGIN
  [LAMBDA (QUIET)                                        (* bvm%: "17-SEP-83 14:18")
    (DECLARE (USEDFREE GVUSERNAME GVPASSWORD LASTNAME LASTSTRING))
    (PROG ((ALWAYSASK (NULL QUIET))
           LOGINFO UPNAME PASSKEY EC)
      LP  (COND
             ((NOT (SETQ LOGINFO (\INTERNAL/GETPASSWORD 'GV ALWAYSASK)))
              (RETURN)))
          (SETQ UPNAME (\CHECKNAME (CAR LOGINFO)))
          (COND
             ((EQ [SETQ EC (GV.AUTHENTICATE UPNAME (SETQ PASSKEY (GV.MAKEKEY (CDR LOGINFO]
                  T)
              (printout T T "User " [SETQ LASTSTRING (SETQ LASTNAME (CONCAT (CAR UPNAME)
                                                                           "."
                                                                           (CDR UPNAME]
                     " logged in." T)
              (SETQ GVUSERNAME UPNAME)
              (SETQ GVPASSWORD PASSKEY))
             (T (printout T EC)
                (SETQ ALWAYSASK T)
                (GO LP)))
          (RETURN LASTNAME])

(\MT.REMOVE.FRIEND
  [LAMBDA NIL                                            (* bvm%: "17-SEP-83 14:18")
    (\MT.CHANGE.GROUP.COMPONENT (FUNCTION GV.REMOVEFRIEND)
           'REMOVE])

(\MT.REMOVE.MEMBER
  [LAMBDA NIL                                            (* bvm%: "17-SEP-83 14:18")
    (\MT.CHANGE.GROUP.COMPONENT (FUNCTION GV.REMOVEMEMBER)
           'REMOVE])

(\MT.REMOVE.OWNER
  [LAMBDA NIL                                            (* bvm%: "26-Apr-84 10:44")
    (\MT.CHANGE.GROUP.COMPONENT (FUNCTION GV.REMOVEOWNER)
           'REMOVE])

(\MT.TYPE.ENTRY
  [LAMBDA NIL                                            (* bvm%: "23-Mar-84 12:07")
    (PROG (GVNAMETYPE RNAME)
          (DECLARE (SPECVARS GVNAMETYPE RNAME)
                 (USEDFREE LASTNAME LASTGROUP LASTSTRING))   (* RNAME is used by 
                                                           \MT.RECEIVE.ENTRY)
          (COND
             ((SETQ RNAME (\MT.READRNAME " for R-Name: " LASTSTRING))
              (.ELLIPSIS.)
              (COND
                 ((EQ (GV.READENTRY RNAME NIL (FUNCTION \MT.RECEIVE.ENTRY))
                      'BadRName)
                  (printout T T "Name not found" T)))
              (SETQ LASTSTRING RNAME])

(\MT.TYPE.MEMBERS
  [LAMBDA NIL                                            (* bvm%: "22-Mar-84 18:53")
    (PROG (GVNAMETYPE NAME INFO)
          (DECLARE (SPECVARS GVNAMETYPE)
                 (USEDFREE LASTNAME LASTGROUP LASTSTRING))
          (COND
             ((SETQ NAME (\MT.READRNAME " of group: " LASTGROUP))
              (.ELLIPSIS.)
              (GV.READMEMBERS NAME NIL (FUNCTION \MT.PRINTRLIST))
              (SELECTC GVNAMETYPE
                  (\NAMETYPE.GROUP 
                       (SETQ LASTGROUP NAME))
                  (\NAMETYPE.INDIVIDUAL 
                       (printout T T "Can't: " NAME " is an individual")
                       (SETQ LASTNAME NAME))
                  (printout T T "Name not found"))
              (TERPRI T)
              (SETQ LASTSTRING NAME])
)
(DEFINEQ

(\MT.MAYBE.PRINT.OVERSTAMPED.RLIST
  [LAMBDA (INSTREAM OUTSTREAM HEADING EVENIFNIL)         (* bvm%: "22-Mar-84 18:49")

         (* * Print a component consisting of an RList, a stamp list, a "removal" RList
       (not interesting) and another stamp list)

    (\MT.PRINTSTRINGLIST INSTREAM OUTSTREAM HEADING EVENIFNIL)
    (\SKIPCOMPONENT INSTREAM)
    (\SKIPCOMPONENT INSTREAM)
    (\SKIPCOMPONENT INSTREAM])

(\MT.MAYBE.PRINT.STRING
  [LAMBDA (INSTREAM OUTSTREAM HEADING)                   (* bvm%: "20-Jul-85 16:56")
    (PROG (STRLEN)
          (COND
             ((AND (NEQ (\WIN INSTREAM)
                        0)
                   (NEQ (SETQ STRLEN (PROGN (\RECEIVESTAMP INSTREAM T)
                                                             (* Skip stamp)
                                            (\WIN INSTREAM)))
                        0))
              (AND HEADING (PRIN1 HEADING OUTSTREAM))
              (RPTQ STRLEN (\OUTCHAR OUTSTREAM (BIN INSTREAM)))
              (COND
                 ((ODDP STRLEN)
                  (BIN INSTREAM)))
              (AND HEADING (TERPRI OUTSTREAM])

(\MT.PRINTRLIST
  [LAMBDA (INSTREAM)                                     (* bvm%: "22-Mar-84 18:53")

         (* Response fn for operations that read a list of strings.
       Expects to see a stamp followed by a list of strings.
       Strings are printed to T)

    (\RECEIVESTAMP INSTREAM T)
    (TERPRI T)
    (\MT.PRINTSTRINGLIST INSTREAM (GETSTREAM T 'OUTPUT])

(\MT.PRINTSTRINGLIST
  [LAMBDA (INSTREAM OUTSTREAM HEADING EVENIFNIL SEPR)    (* ; "Edited 15-Jun-90 18:29 by jds")

         (* * Interprets list of components coming on INSTREAM as a list of strings, and 
       prints them to OUTSTREAM, separating strings with SEPR)

    (OR SEPR (SETQ SEPR ", "))
    (PROG ((CNT 0)
           (NWORDS (\WIN INSTREAM))
           STRLEN RMAR)
          (COND
             ((EQ NWORDS 0)
              (COND
                 (EVENIFNIL (printout OUTSTREAM HEADING "null" T)))
              (RETURN 0)))
          (COND
             (HEADING (PRIN1 HEADING OUTSTREAM)))
          (SETQ RMAR (LINELENGTH NIL OUTSTREAM))
          [do (add CNT 1)
                 (SETQ STRLEN (\WIN INSTREAM))
                 (\WIN INSTREAM)                             (* ignore maxLength)
                 (AND (IGREATERP (IPLUS (IPLUS STRLEN 2)
                                        (fetch (STREAM CHARPOSITION) of OUTSTREAM))
                             RMAR)
                      (FRESHLINE OUTSTREAM))
                 (FRPTQ STRLEN (\OUTCHAR OUTSTREAM (BIN INSTREAM)))
                 (COND
                    ((ODDP STRLEN)                           (* read padding)
                     (BIN INSTREAM)))
                 (SETQ NWORDS (IDIFFERENCE NWORDS (IPLUS (FOLDHI STRLEN BYTESPERWORD)
                                                         2)))
                 (COND
                    ((IGREATERP NWORDS 0)
                     (PRIN1 SEPR OUTSTREAM))
                    (T (RETURN]
          (AND HEADING (TERPRI OUTSTREAM))
          (RETURN CNT])

(\SKIPCOMPONENT
  [LAMBDA (STREAM)                                       (* bvm%: "20-Jul-85 16:55")
                                                             (* Skips over a component, which is 
                                                           a word count followed by that many 
                                                           words)
    (to (\WIN STREAM) do (\WIN STREAM])

(\MT.SKIPSTRINGLIST
  [LAMBDA (INSTREAM)                                     (* bvm%: "20-Jul-85 16:55")

         (* * Interprets list of components coming on INSTREAM as a list of strings, and 
       counts them without printing them)

    (bind (CNT _ 0)
           (NWORDS _ (\WIN INSTREAM))
           STRLEN while (IGREATERP NWORDS 0) do (add CNT 1)
                                                       (SETQ STRLEN (\WIN INSTREAM))
                                                       (\WIN INSTREAM) 
                                                             (* ignore maxLength)
                                                       (FRPTQ STRLEN (BIN INSTREAM))
                                                       (COND
                                                          ((ODDP STRLEN)
                                                             (* read padding)
                                                           (BIN INSTREAM)))
                                                       (SETQ NWORDS (IDIFFERENCE NWORDS
                                                                           (IPLUS (FOLDHI STRLEN 
                                                                                         BYTESPERWORD
                                                                                         )
                                                                                  2)))
       finally (RETURN CNT])

(\MT.RECEIVE.ENTRY
  [LAMBDA (INSTREAM)                                     (* bvm%: "20-Jul-85 16:56")
    (DECLARE (USEDFREE LASTNAME LASTGROUP RNAME))

         (* * Called by GV.READENTRY to parse and display some of what Grapevine sends 
       back as "the entire database entry" for NAME.
       The contents are different for groups, individuals, and dead folk)

    (PROG ((OUTSTREAM (GETSTREAM T 'OUTPUT))
           NAMETYPE)
          (\RECEIVESTAMP INSTREAM T)                         (* Skip stamp)
          (\WIN INSTREAM)                                    (* Skip component count)
          (TERPRI OUTSTREAM)
          (COND
             ((NEQ NAMETYPE \NAMETYPE.NOTFOUND)

         (* There is a database entry. First component is the "prefix" %, which 
       contains, among other things, the name's type and its "official" name)

              (\WIN INSTREAM)                                (* Length of this component)
              (\RECEIVESTAMP INSTREAM T)                     (* Skip stamp)
              (SETQ NAMETYPE (\WIN INSTREAM))
              (printout OUTSTREAM (SETQ RNAME (\RECEIVERNAME INSTREAM))
                     " is ")))
          (SELECTC NAMETYPE
              (\NAMETYPE.INDIVIDUAL 
                   (printout OUTSTREAM "an individual" T)
                   (\SKIPCOMPONENT INSTREAM)             (* Skip password)
                   (\MT.MAYBE.PRINT.STRING INSTREAM OUTSTREAM "Connect-site: ")
                   (\MT.MAYBE.PRINT.OVERSTAMPED.RLIST INSTREAM OUTSTREAM "Forwarding: ")
                   (\MT.MAYBE.PRINT.OVERSTAMPED.RLIST INSTREAM OUTSTREAM "Mailbox-sites: ")
                   (SETQ LASTNAME RNAME))
              (\NAMETYPE.GROUP 
                   (printout OUTSTREAM "a group" T)
                   (\MT.MAYBE.PRINT.STRING INSTREAM OUTSTREAM "Remark: ")
                   (printout OUTSTREAM "Number of members: " |.P2| (\MT.SKIPSTRINGLIST INSTREAM)
                          T)
                   (\SKIPCOMPONENT INSTREAM)             (* Skip stamp list)
                   (\SKIPCOMPONENT INSTREAM)             (* Skip DelMembers)
                   (\SKIPCOMPONENT INSTREAM)             (* Skip stamp list)
                   (\MT.MAYBE.PRINT.OVERSTAMPED.RLIST INSTREAM OUTSTREAM "Owners: " T)
                   (\MT.MAYBE.PRINT.OVERSTAMPED.RLIST INSTREAM OUTSTREAM "Friends: " T)
                   (SETQ LASTGROUP RNAME))
              (\NAMETYPE.DEAD 
                   (printout OUTSTREAM "dead" T))
              NIL])
)
(DEFINEQ

(\MT.READRNAME
  [LAMBDA (PROMPT DEFAULT)                               (* bvm%: "20-Jul-85 17:58")
    (PROG ((NAME (PROMPTFORWORD PROMPT DEFAULT NIL T NIL NIL RNAMEDELIMITERS)))
          [COND
             ((NULL NAME)
              (printout T " xxx" T)
              (RETURN))
             ((AND (NOT (STRPOS "." NAME))
                   (NOT (STRPOS "*" NAME)))                  (* No registry included and "name" 
                                                           is not a pattern)
              (printout T "." DEFAULTREGISTRY)
              (SETQ NAME (CONCAT NAME "." DEFAULTREGISTRY]
          (RETURN NAME])

(\MT.PERMIT.NS
  [LAMBDA NIL                                                (* Let users type names with spaces 
                                                           etc in them)
    (SETQ RNAMEDELIMITERS (CHARCODE (CR])
)

(RPAQQ \MT.ELLIPSIS " ... ")
(DECLARE%: EVAL@COMPILE DONTCOPY 

(RPAQQ GVNAMETYPES ((\NAMETYPE.GROUP 0)
                        (\NAMETYPE.INDIVIDUAL 1)
                        (\NAMETYPE.NOTFOUND 2)
                        (\NAMETYPE.DEAD 3)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \NAMETYPE.GROUP 0)

(RPAQQ \NAMETYPE.INDIVIDUAL 1)

(RPAQQ \NAMETYPE.NOTFOUND 2)

(RPAQQ \NAMETYPE.DEAD 3)


(CONSTANTS (\NAMETYPE.GROUP 0)
       (\NAMETYPE.INDIVIDUAL 1)
       (\NAMETYPE.NOTFOUND 2)
       (\NAMETYPE.DEAD 3))
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS .ELLIPSIS. MACRO (NIL (printout T \MT.ELLIPSIS)))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \MT.ELLIPSIS)
)
)

(FILESLOAD GRAPEVINE)
(PUTPROPS MAINTAIN COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1235 3708 (MAINTAIN 1245 . 1731) (\GETMAINTAINCOMMAND 1733 . 3706)) (3709 12198 (
\MT.ADD.FRIEND 3719 . 3909) (\MT.ADD.MEMBER 3911 . 4101) (\MT.ADD.OWNER 4103 . 4291) (
\MT.CHANGE.PASSWORD 4293 . 5689) (\MT.CHANGE.REMARK 5691 . 6764) (\MT.CHANGE.GROUP.COMPONENT 6766 . 
7883) (\MT.LIST.GROUPS 7885 . 9030) (\MT.LOGIN 9032 . 10073) (\MT.REMOVE.FRIEND 10075 . 10274) (
\MT.REMOVE.MEMBER 10276 . 10475) (\MT.REMOVE.OWNER 10477 . 10674) (\MT.TYPE.ENTRY 10676 . 11375) (
\MT.TYPE.MEMBERS 11377 . 12196)) (12199 19975 (\MT.MAYBE.PRINT.OVERSTAMPED.RLIST 12209 . 12657) (
\MT.MAYBE.PRINT.STRING 12659 . 13374) (\MT.PRINTRLIST 13376 . 13771) (\MT.PRINTSTRINGLIST 13773 . 
15411) (\SKIPCOMPONENT 15413 . 15844) (\MT.SKIPSTRINGLIST 15846 . 17357) (\MT.RECEIVE.ENTRY 17359 . 
19973)) (19976 20877 (\MT.READRNAME 19986 . 20635) (\MT.PERMIT.NS 20637 . 20875)))))
STOP
\ No newline at end of file
diff --git a/internal/library/MAKE-EXPORTS-ALL b/internal/library/MAKE-EXPORTS-ALL
new file mode 100644
index 00000000..becbe3e6
--- /dev/null
+++ b/internal/library/MAKE-EXPORTS-ALL
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 3-May-2018 15:37:56" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>internal>library>MAKE-EXPORTS-ALL.;1 1800   

      changes to%:  (VARS MAKE-EXPORTS-ALLCOMS))


(PRETTYCOMPRINT MAKE-EXPORTS-ALLCOMS)

(RPAQQ MAKE-EXPORTS-ALLCOMS
       ((* "Edited May 3, 2018 by Ron Kaplan--relative to MEDLEYDIR/lispcore/.  Don't know why it does the CORE/RENAME"
           )
        (* 
          "Edited Aug 17 94 by Sybalsky -- point it to /king/export/lispcore as the truth directory."
           )
        (* "Edited July 5, 1990 by Sybalsky -- point it to Pele as the truth directory.")
        (* "Edited September 29, 1986 by van Melle")
        (P (BKSYSBUF '(PROGN (CNDIR (CONCAT (UNIX-GETENV "MEDLEYDIR")
                                           '/lispcore/sources/))
                             (LOAD 'FILESETS)
                             (RENAMEFILE (GATHEREXPORTS EXPORTFILES '{CORE}EXPORTS.ALL)
                                    '../library/EXPORTS.ALL))
                  T))))



(* 
"Edited May 3, 2018 by Ron Kaplan--relative to MEDLEYDIR/lispcore/.  Don't know why it does the CORE/RENAME"
)




(* "Edited Aug 17 94 by Sybalsky -- point it to /king/export/lispcore as the truth directory.")




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




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


(BKSYSBUF '(PROGN (CNDIR (CONCAT (UNIX-GETENV "MEDLEYDIR")
                                '/lispcore/sources/))
                  (LOAD 'FILESETS)
                  (RENAMEFILE (GATHEREXPORTS EXPORTFILES '{CORE}EXPORTS.ALL)
                         '../library/EXPORTS.ALL))
       T)
(PUTPROPS MAKE-EXPORTS-ALL COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/internal/library/MAKE-TCP-EXPORTS b/internal/library/MAKE-TCP-EXPORTS
new file mode 100644
index 00000000..3c7a124c
--- /dev/null
+++ b/internal/library/MAKE-TCP-EXPORTS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 10:32:43" 
|{DSK}<usr>local>lde>lispcore>internal>library>MAKE-TCP-EXPORTS.;2| 1356   

      |changes| |to:|  (VARS MAKE-TCP-EXPORTSCOMS)

      |previous| |date:| "14-Jul-88 19:44:17" 
|{DSK}<usr>local>lde>lispcore>internal>library>MAKE-TCP-EXPORTS.;1|)


; Copyright (c) 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT MAKE-TCP-EXPORTSCOMS)

(RPAQQ MAKE-TCP-EXPORTSCOMS ((VARIABLES XCL-USER::*TCP-EXPORT-LIST*)))

(DEFGLOBALVAR XCL-USER::*TCP-EXPORT-LIST*
   '(XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCP XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPCHAT 
           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPCONFIG XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPDEBUG 
           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPDOMAIN XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPFTP 
           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPFTPSRV XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPHTE 
           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPLLAR XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPLLICMP 
           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPLLIP XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPNAMES 
           XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPTFTP XCL-USER::{ERIS}<LISPCORE>LIBRARY>TCPUDP))
(PUTPROPS MAKE-TCP-EXPORTS COPYRIGHT ("Venue & Xerox Corporation" 1988 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/internal/library/MESATYPES b/internal/library/MESATYPES
new file mode 100644
index 00000000..35cfb8d3
--- /dev/null
+++ b/internal/library/MESATYPES
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 18:38:14" {DSK}<usr>local>lde>lispcore>internal>library>MESATYPES.;2 16783  

      changes to%:  (VARS MESATYPESCOMS)

      previous date%: " 5-Oct-84 12:16:00" {DSK}<usr>local>lde>lispcore>internal>library>MESATYPES.;1
)


(* ; "
Copyright (c) 1984, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT MESATYPESCOMS)

(RPAQQ MESATYPESCOMS
       ((* Defines three new record types%: MESATYPE, MESARECORD, and MESAARAY. Also provides a 
           number of macros to manipulate objects of these record types. None of this package need be
           present in the compiled version of a client package.)
        (* Public stuff)
        (MACROS MESASIZE MESASETQ MESAEQUAL FMESAELT MESAELT MESASETA)
        (PROP ARGNAMES MESASIZE MESASETQ MESAEQUAL FMESAELT MESAELT MESASETA)
        (* Private stuff)
        (INITVARS (\MESATYPES (HASHARRAY 20)))
        (P (pushnew CLISPRECORDTYPES 'MESATYPE)
           (pushnew CLISPRECORDTYPES 'MESARECORD)
           (pushnew CLISPRECORDTYPES 'MESAARRAY)
           (MOVD 'RECORD 'MESATYPE)
           (MOVD 'RECORD 'MESARECORD)
           (MOVD 'RECORD 'MESAARRAY))
        (PROP USERRECORDTYPE MESATYPE MESARECORD MESAARRAY)
        (FNS MESATYPEFN MESARECORDFN MesaRecordFields MesaRecordSubblock MesaRecordCreateMethod 
             MESAARRAYFN MesaArrayOffsets MesaArrayFindOffset RemoveLast)))



(* Defines three new record types%: MESATYPE, MESARECORD, and MESAARAY. Also provides a number of 
macros to manipulate objects of these record types. None of this package need be present in the 
compiled version of a client package.)




(* Public stuff)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS MESASIZE MACRO [args (PROG ((recordName (CAR args)))
                                                             (* Returns the size of record 
                                                           recordName)
                                             (RETURN (EVAL `(INDEXF (fetch (%, recordName 
                                                                                   THISISTHELASTFIELD
                                                                                   ) of T])

(PUTPROPS MESASETQ MACRO [args (PROG ((a (CAR args))
                                              (b (CADR args))
                                              (type (CADDR args)))

         (* Copies the contents of "b" into "a" Returns a.
       Should be used to translate statement of the form "a _ b;" when a and b are 
       neither numbers nor pointers. A safer (ie, more correct) way to do this would 
       be to say "(foreach field f in type st f has both a fetch and a replace method do (replace (type f) of a with (fetch (type f) of b)))")

                                             (RETURN `(\BLT %, a %, b (MESASIZE %, type])

(PUTPROPS MESAEQUAL MACRO [args (PROG ((a (CAR args))
                                               (b (CADR args))
                                               (type (CADDR args)))

         (* Compares a and b for equality, where a and b are instances of record type.
       a and b can be multiple words long.)

                                              (RETURN `(for word from 0
                                                          to (SUB1 (MESASIZE %, type))
                                                          always (EQ (\GETBASE %, a word)
                                                                         (\GETBASE %, b word])

(PUTPROPS FMESAELT MACRO
          [args
           (PROG ((array (CAR args))
                  (arrayType (CADR args))
                  (indexes (CDDR args))
                  indexRangeList indexOffsetList)

         (* Returns a pointer to the indicated element of array.
       Unsafe, because it returns a pointer to the middle of the structure, which 
       would confuse the garbage collector if you held onto the element pointer longer 
       than the array pointer.)

                 [SETQ indexRangeList (EVAL `(fetch (%, arrayType INDEXLIST) of T]
                 [SETQ indexOffsetList (EVAL `(fetch (%, arrayType OFFSETLIST) of T]
                 (RETURN (LIST '\ADDBASE array
                               (CONS 'IPLUS
                                     (for index in indexes as indexRange in 
                                                                                       indexRangeList
                                        as offset in indexOffsetList
                                        collect `([OPENLAMBDA (index)
                                                             (OR (AND (ILEQ %, (CAR indexRange)
                                                                            index)
                                                                      (ILEQ index %, (CDR indexRange)
                                                                            ))
                                                                 (ERROR 'indexOutOfRange))
                                                             (ITIMES %, offset (IDIFFERENCE
                                                                                index %, (CAR 
                                                                                           indexRange
                                                                                              ]
                                                      %, index])

(PUTPROPS MESAELT MACRO [args (PROG ((arrayType (CADR args))
                                             elementType)

         (* Returns the selected element of the array.
       Copies it into a freshly allocated box to avoid returning a pointer to the 
       middle of the structure, which might confuse the garbage collector.)

                                            [SETQ elementType (EVAL `(fetch (%, arrayType 
                                                                                    ELEMENTTYPE)
                                                                        of T]
                                            (RETURN `(MESASETQ (create %, elementType)
                                                            %,
                                                            (CONS 'FMESAELT args)
                                                            %, elementType])

(PUTPROPS MESASETA MACRO [args (PROG ((eltArgs (RemoveLast args))
                                              (arrayType (CADR args))
                                              (newValue (CAR (LAST args)))
                                              elementType)

         (* Replaces the index'th element of array, provided that array is a contiguous 
       run of objects of type elementType)

                                             [SETQ elementType (EVAL `(fetch (%, arrayType 
                                                                                     ELEMENTTYPE)
                                                                         of T]
                                             (RETURN `(MESASETQ %, (CONS 'FMESAELT eltArgs)
                                                             %, newValue %, elementType])
)

(PUTPROPS MESASIZE ARGNAMES (recordName))

(PUTPROPS MESASETQ ARGNAMES (a b type))

(PUTPROPS MESAEQUAL ARGNAMES (a b type))

(PUTPROPS FMESAELT ARGNAMES (array arrayType index1 |...| indexn))

(PUTPROPS MESAELT ARGNAMES (array arrayType index1 |...| indexn))

(PUTPROPS MESASETA ARGNAMES (array arrayType index1 |...| indexn newValue))



(* Private stuff)


(RPAQ? \MESATYPES (HASHARRAY 20))

(pushnew CLISPRECORDTYPES 'MESATYPE)

(pushnew CLISPRECORDTYPES 'MESARECORD)

(pushnew CLISPRECORDTYPES 'MESAARRAY)

(MOVD 'RECORD 'MESATYPE)

(MOVD 'RECORD 'MESARECORD)

(MOVD 'RECORD 'MESAARRAY)

(PUTPROPS MESATYPE USERRECORDTYPE MESATYPEFN)

(PUTPROPS MESARECORD USERRECORDTYPE MESARECORDFN)

(PUTPROPS MESAARRAY USERRECORDTYPE MESAARRAYFN)
(DEFINEQ

(MESATYPEFN
  [LAMBDA (typeDecl)                                     (* hts%: "24-Mar-84 19:46")
    (PROG ((typeName (CADR typeDecl))
           (isType (CADDR typeDecl))
           (rest (CDDDR typeDecl)))
          (RETURN (NCONC (LIST 'MESARECORD typeName (LIST (CONS 'DATA isType)))
                         rest])

(MESARECORDFN
  [LAMBDA (recordDecl)                                   (* edited%: "31-Mar-84 16:34")
                                                             (* Translates a MESARECORD 
                                                           declaration into a BLOCKRECORD.)

         (* For each multi-word (gt 2) field, creates a special fetch method that 
       returns a pointer to the beginning of the field, and a replace method that uses 
       \BLT to copy over the entire field. This is done by replacing the fieldname 
       with fieldnameSTARTOFTHISFIELD and making the fetch method for fieldname be a 
       LOCF on fieldnameSTARTOFTHISFIELD)

         (* Note that a field can be declared to be a multi-word field by saying either
       (fieldname N WORD) or (fieldname mumble)%, where mumble is a previously defined 
       MESARECORD.)

         (* Also includes a CREATE method for the type.
       if the user has not already done so. (Uses \ALLOCBLOCK.
       The messy-looking arithmetic is because MESASIZE returns the size of a record 
       in words, and \ALLOCBLOCK's arg specifies the %# of pointer cells
       (2 words each) to allocate))

    (PROG ((recordName (CADR recordDecl))
           (fieldDeclarations (CADDR recordDecl))
           (subblocks (CONS))
           (rest (CDDDR recordDecl)))
          (RETURN (PROG1 (NCONC [LIST 'BLOCKRECORD recordName (NCONC (MesaRecordFields 
                                                                            fieldDeclarations)
                                                                     (LIST '(THISISTHELASTFIELD
                                                                             WORD]
                                (CAR subblocks)
                                (MesaRecordCreateMethod recordName rest)
                                rest)
                      (PUTHASH recordName T \MESATYPES)      (* Record that recordName is a new 
                                                           MESARECORD)
                      )])

(MesaRecordFields
  [LAMBDA (fieldDeclarations)                            (* hts%: "29-Mar-84 18:04")
    (for field in fieldDeclarations
       collect (if [AND (CAR field)
                                (OR (GETHASH (CADR field)
                                           \MESATYPES)
                                    (AND (EQ (CADDR field)
                                             'WORD)
                                         (FIXP (CADR field))
                                         (IGREATERP (CADR field)
                                                2]
                       then (TCONC subblocks (MesaRecordSubblock recordName field))
                             (LIST (PACK* (CAR field)
                                          'STARTOFTHISFIELD)
                                   [OR (FIXP (CADR field))
                                       (EVAL `(MESASIZE %, (CADR field]
                                   'WORD)
                     else field])

(MesaRecordSubblock
  [LAMBDA (recordName fieldDeclaration)                  (* hts%: "29-Mar-84 18:05")
                                                             (* Returns the appropriate accessfn 
                                                           declaration to make fieldDeclaration 
                                                           a multi-word subblock.)
    (PROG ((fieldName (CAR fieldDeclaration))
           (fieldSize (CADR fieldDeclaration)))
          [OR (FIXP fieldSize)
              (SETQ fieldSize (EVAL `(MESASIZE %, fieldSize]
          (RETURN (LIST 'ACCESSFNS (LIST fieldName (LIST 'LOCF (LIST 'fetch
                                                                     (LIST recordName
                                                                           (PACK* fieldName
                                                                                  'STARTOFTHISFIELD))
                                                                     'of
                                                                     'DATUM))
                                         (LIST 'PROGN (LIST '\BLT (LIST 'fetch (LIST recordName 
                                                                                     fieldName)
                                                                        'of
                                                                        'DATUM)
                                                            'NEWVALUE fieldSize)
                                               'NEWVALUE])

(MesaRecordCreateMethod
  [LAMBDA (recordName rest)                              (* edited%: "31-Mar-84 16:31")

         (* Returns a create method for the type, if the user has not already done so.)

    (if (for thing in rest thereis (EQ 'CREATE (CAR thing)))
        then NIL
      else (LIST `(CREATE (\ALLOCBLOCK (LRSH (ADD1 (MESASIZE %, recordName))
                                                     1])

(MESAARRAYFN
  [LAMBDA (arrayDecl)                                    (* hts%: "18-Apr-84 14:21")
    (PROG ((arrayName (CADR arrayDecl))
           (indexDeclarations (CADDR arrayDecl))
           (elementType (CADDDR arrayDecl))
           (rest (CDDDDR arrayDecl))
           arrayOffsets)
          [SETQ indexDeclarations (for indexDecl in indexDeclarations
                                     collect (CONS (EVAL (CAR indexDecl))
                                                       (EVAL (CADR indexDecl]
                                                             (* Evaluate arraybounds so that they 
                                                           can be expressions rather than 
                                                           integers.)
          (SETQ arrayOffsets (MesaArrayOffsets indexDeclarations elementType))
          (RETURN (APPEND `[MESARECORD %, arrayName ((DATA %, (MesaArrayFindOffset 
                                                                     indexDeclarations arrayOffsets 
                                                                     elementType)
                                                           WORD))
                                  (ACCESSFNS ((INDEXLIST (QUOTE %, indexDeclarations))
                                              (OFFSETLIST (QUOTE %, arrayOffsets))
                                              (ELEMENTTYPE (QUOTE %, elementType]
                         rest])

(MesaArrayOffsets
  [LAMBDA (indexDeclarations elementType)                (* hts%: "24-Mar-84 20:15")
    (if (NULL indexDeclarations)
        then NIL
      else (PROG ((restOfOffsets (MesaArrayOffsets (CDR indexDeclarations)
                                            elementType)))
                     (RETURN (CONS (MesaArrayFindOffset (CDR indexDeclarations)
                                          restOfOffsets elementType)
                                   restOfOffsets])

(MesaArrayFindOffset
  [LAMBDA (indexDeclarations arrayOffsets elementType)   (* hts%: "18-Apr-84 14:29")
    (if indexDeclarations
        then (ITIMES (ADD1 (IDIFFERENCE (CDAR indexDeclarations)
                                      (CAAR indexDeclarations)))
                        (CAR arrayOffsets))
      else (EVAL `(MESASIZE %, elementType])

(RemoveLast
  [LAMBDA (list)                                         (* hts%: "26-Mar-84 00:04")
    (PROG ((newList (COPY list))
           length)
          (SETQ length (LENGTH newList))
          (if (ILEQ length 1)
              then (RETURN NIL)
            else (RPLACD (FNTH newList (SUB1 length)))
                  (RETURN newList])
)
(PUTPROPS MESATYPES COPYRIGHT ("Venue & Xerox Corporation" 1984 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (8350 16689 (MESATYPEFN 8360 . 8691) (MESARECORDFN 8693 . 10835) (MesaRecordFields 10837
 . 11858) (MesaRecordSubblock 11860 . 13448) (MesaRecordCreateMethod 13450 . 13907) (MESAARRAYFN 13909
 . 15423) (MesaArrayOffsets 15425 . 15943) (MesaArrayFindOffset 15945 . 16319) (RemoveLast 16321 . 
16687)))))
STOP
\ No newline at end of file
diff --git a/internal/library/MESATYPES.TEDIT b/internal/library/MESATYPES.TEDIT
new file mode 100644
index 00000000..8548530b
--- /dev/null
+++ b/internal/library/MESATYPES.TEDIT
@@ -0,0 +1 @@
+Subject: New Lispcore>Library package: MesaTypes
To: Lispcore^, Lispsupport, Sheil, Cooper, Purcell

Announcing a new Lispcore>Library package: MesaTypes

By Tayloe Stansbury with help from Richard Burton.

This package introduces three new clisprecordtypes which allow you to describe any block of bits with an arbitrarily nested datatype.  You can define multidimensional, nonstandardly indexed arrays with multi-word elements; records with multi-word fields; and multi-word types.  Special accessfns cover up the necessary \BLTs and LOCFs.  Appropriate create methods are automatically provided.  The package also provides a number of macros for manipulating instances of such types.  

Anyone who wants to use graceful datatypes to describe some arbitrary chunk of memory (e.g. ethernet, rs232, nsfiling, any file system)  will probably find this package useful; most of the 1108 file system now depends on it.  People translating Mesa system code into Lisp will find it particularly useful.

This message is stored as Lispcore>Library>MesaTypes.tedit.  Proper external documentation of this package will follow release of the 1108 file system.  Extensive examples of its use can be found in the first few pages of stansbury>newdlionfs>dlionfs.

-- Tayloe.
\ No newline at end of file
diff --git a/internal/library/MULTI-COMPILE b/internal/library/MULTI-COMPILE
new file mode 100644
index 00000000..c5767422
--- /dev/null
+++ b/internal/library/MULTI-COMPILE
@@ -0,0 +1,374 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+(FILECREATED "16-Nov-94 16:28:04" |{DSK}<lispcore>internal>library>MULTI-COMPILE.;4| 37236  
+
+      |changes| |to:|  (VARS MULTI-COMPILECOMS)
+                       (FNS FIND-UNCOMPILED-FILES)
+
+      |previous| |date:| " 9-Sep-94 13:03:19" |{DSK}<lispcore>internal>library>MULTI-COMPILE.;3|)
+
+
+; Copyright (c) 1988, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT MULTI-COMPILECOMS)
+
+(RPAQQ MULTI-COMPILECOMS
+       (
+        (* |;;| "Support for compiling multiple files in one pass, for a bulk recompilation of the system (or some part of it).")
+
+        (COMS                                                (* \; "Function to compile multiple files without having one step on the next (so you could compile all the system with it).")
+              (FUNCTIONS BIGCOMP))
+        (COMS                                                (* \; "Function to identify all the source files on a given directory (useful for creating lists of things to compile)")
+              (FUNCTIONS FIND-ALL-SOURCE-FILES)
+              (FNS FIND-UNCOMPILED-FILES))
+        (COMS                                                (* \; 
+                                            "Misc utility functions from the big Lyric recompiles.")
+              (FNS NEWERDCOMS? NEWERSOURCES? SETUP-FOR-RECOMPILE SMASH-OPCODES GET-DIRECTORY-LISTING
+                   GET-OPEN-FILES)
+              
+              (* |;;| "Control variables")
+
+              (VARS FILES-IN-FULL.SYSOUT FILES-IN-LIBRARY FILES-IN-LISP.SYSOUT FILES-IN-SOURCES 
+                    FORKED-FILES GARBAGE-OPCODES))
+        (COMS                                                (* \; 
+                                    "Utilities for making mass-scale fixups to a library of files.")
+              (FNS FIX-FILES FIX-FILE FIX-COPYRIGHT FIX-FILE-COPYRIGHT QUALIFY-FIELDS FIX-TEDIT 
+                   FIX-DOCS))
+        
+        (* |;;| "Removes bogus (CLISP  <clisp xlation> <real-code>) translations that result from CLISPARRAY being NIL.")
+
+        (FNS CLFIX)
+        (PROP FILETYPE MULTI-COMPILE)
+        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA FIX-FILES)))))
+
+
+
+(* |;;| 
+"Support for compiling multiple files in one pass, for a bulk recompilation of the system (or some part of it)."
+)
+
+
+
+
+(* \; 
+"Function to compile multiple files without having one step on the next (so you could compile all the system with it)."
+)
+
+
+(CL:DEFUN BIGCOMP (FILENAMES SOURCEDIRS DESTDIR &OPTIONAL (DRIBBLE-FILE '"{DSK}BIGCOMP.DRIBBLE")
+                             DELETE-DCOMS? DELETE-DRIBBLE?)
+
+   (* |;;| "Compile all the files in the system.")
+
+   (LET ((COMPLETION 'ERROR)
+         (NUM-FILES (LENGTH FILENAMES)))
+        (IDLE.SET.OPTION 'TIMEOUT T)                         (* \; "never idle")
+        (SETQ NOSPELLFLG T)                                  (* \; "death to DWIM!")
+        (SETQ DWIMIFYCOMPFLG NIL)                            (* \; "I mean it")
+
+        (* |;;| "do it")
+
+        (CL:UNWIND-PROTECT
+            (PROGN (DRIBBLE DRIBBLE-FILE)
+                   (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM))
+                          'PAGEFULLFN
+                          'NILL)
+                   (PRINTOUT NIL "= = = = = Setting up for full-system compilation run on " (DATE)
+                          " = = = = =" T T)
+                   (|for| FILE |in| FILENAMES |as| FILE-NUM |from| 1
+                      |do| (DSPNEWPAGE (GETSTREAM NIL 'OUTPUT)) 
+
+                            (* |;;| "changed the destfile so it has the proper extension.  It was compiling everything correctly, but naming all the files .lcom.")
+
+                            (LET* ((CF (COMPILE-FILE? FILE))
+                                   (SOURCEFILE (FINDFILE FILE NIL SOURCEDIRS))
+                                   (DESTFILE (PACKFILENAME 'BODY FILE 'DIRECTORY DESTDIR 'EXTENSION
+                                                    (SELECTQ CF
+                                                        (CL:COMPILE-FILE 
+                                                             'DFASL)
+                                                        'LCOM))))
+                                  (RESETLST
+                                      (RESETSAVE (RESETUNDO))
+                                      (PRINTOUT NIL T "- - - " (OR CF 'BCOMPL)
+                                             "'ing file " SOURCEFILE " to " DESTFILE " at " (DATE)
+                                             " - - -" T)
+                                      (PRINTOUT NIL T "(File number " FILE-NUM " of " NUM-FILES ": "
+                                             (- NUM-FILES FILE-NUM)
+                                             " left)" T T)
+                                      (PRINT (SELECTQ CF
+                                                 ((BCOMPL TCOMPL NIL) 
+                                                      (LISPXUNREAD '(F))
+                                                      (CL:FUNCALL (OR CF 'BCOMPL)
+                                                             SOURCEFILE DESTFILE))
+                                                 (CL:FUNCALL CF SOURCEFILE :OUTPUT-FILE DESTFILE))
+                                             T)
+                                      (PRINTOUT NIL T T "- - - End of " FILE " compilation - - -" T))
+                                  (AND DELETE-DCOMS? (DELFILE DESTFILE))))
+                   (PRINTOUT NIL T T T "= = = = = END OF FULL-SYSTEM COMPILATION RUN = = = = =")
+                   (SETQ COMPLETION 'SUCCESS))
+
+            (* |;;| "cleanup forms")
+
+            (PRINTOUT NIL T "Compilation status: " COMPLETION T T)
+            (DRIBBLE)
+            (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM))
+                   'PAGEFULLFN NIL))
+        (SEND.FILE.TO.PRINTER DRIBBLE-FILE)
+        (AND DELETE-DRIBBLE? (DELFILE DRIBBLE-FILE))))
+
+
+
+(* \; 
+"Function to identify all the source files on a given directory (useful for creating lists of things to compile)"
+)
+
+
+(CL:DEFUN FIND-ALL-SOURCE-FILES (DIRECTORY)
+
+   (* |;;| "Return a list of every file that has a compiled equivalent on DIRECTORY.  This is a way of finding out what needs to be recompiled for a bulk compile.")
+
+   (LET ((DFASLS (FOR FILENAME IN (DIRECTORY (PACKFILENAME 'DIRECTORY DIRECTORY 'BODY 
+                                                            "*.DFASL;"))
+                    COLLECT (UNPACKFILENAME FILENAME 'NAME)))
+         (LCOMS (FOR FILENAME IN (DIRECTORY (PACKFILENAME 'DIRECTORY DIRECTORY 'BODY 
+                                                           "*.LCOM;"))
+                   COLLECT (UNPACKFILENAME FILENAME 'NAME))))
+        (UNION (INTERSECTION DFASLS DFASLS)
+               (INTERSECTION LCOMS LCOMS))))
+(DEFINEQ
+
+(FIND-UNCOMPILED-FILES
+  (LAMBDA (SRCDIR DESTDIR)                               (* \; "Edited 16-Nov-94 16:23 by jds")
+    (LET ((SRCFILES (DIRECTORY (PACKFILENAME 'DIRECTORY SRCDIR 'BODY '*.\;)))
+          SFILE DFILE)
+         (|for| FILE |in| SRCFILES |do| (SETQ SFILE (UNPACKFILENAME FILE 'NAME))
+                                                 (COND
+                                                    ((AND (SETQ DFILE (FINDFILE-WITH-EXTENSIONS
+                                                                       SFILE
+                                                                       (LIST DESTDIR)
+                                                                       '(DFASL LCOM)))
+                                                          (ILESSP (GETFILEINFO DFILE 'ICREATIONDATE)
+                                                                 (GETFILEINFO FILE 'ICREATIONDATE)))
+                                                     (PRINTOUT T FILE " needs compiling." T))
+                                                    ((NOT DFILE)
+                                                     (PRINTOUT T FILE " has no compiled version." T))
+                                                    )))))
+)
+
+
+
+(* \; "Misc utility functions from the big Lyric recompiles.")
+
+(DEFINEQ
+
+(NEWERDCOMS?
  (LAMBDA (DIRPAIRS EXTENSIONS FILTER)                   (* \; "Edited  9-Dec-86 21:39 by bvm")
    (OR DIRPAIRS (SETQ DIRPAIRS '(({ERIS}<LISPCORE>NEWSTRING>SOURCES> {ERIS}<LISPCORE>SOURCES>)
                                  ({ERIS}<LISPCORE>NEWSTRING>LIBRARY> {ERIS}<LISPCORE>LIBRARY>)
                                  ({ERIS}<LISPCORE>NEWSTRING>INTERNAL>LIBRARY> 
                                         {ERIS}<LISPCORE>INTERNAL>LIBRARY>))))
    (OR EXTENSIONS (SETQ EXTENSIONS '(LCOM DCOM)))
    (|for| PAIR |in| DIRPAIRS
       |join| (RESETLST
                      (LET ((THISDIR (CAR PAIR))
                            (OTHERDIR (CADR PAIR))
                            (THISEXT (CAR EXTENSIONS))
                            (OTHEREXT (CADR EXTENSIONS))
                            NEXT DT OTHERFILE OTHERDT OTHERWDT THISAUTHOR DIRPRINTED GEN)
                           (SETQ GEN (\\GENERATEFILES (PACKFILENAME.STRING 'DIRECTORY THISDIR
                                                             'NAME "*" 'EXTENSION THISEXT
                                                             'VERSION "")
                                            '(ICREATIONDATE)
                                            '(RESETLST)))
                           (|while| (SETQ NEXT (\\GENERATENEXTFILE GEN)) |eachtime|
                                                                             (SETQ OTHERWDT NIL)
                              |when| (AND (SETQ OTHERFILE (INFILEP (PACKFILENAME.STRING
                                                                        'DIRECTORY OTHERDIR
                                                                        'EXTENSION OTHEREXT
                                                                        'VERSION NIL 'BODY NEXT)))
                                              (SETQ DT (\\GENERATEFILEINFO GEN 'ICREATIONDATE))
                                              (OR (AND (SETQ OTHERDT (GETFILEINFO OTHERFILE
                                                                            'ICREATIONDATE))
                                                       (< DT OTHERDT))
                                                  (AND (SETQ OTHERWDT (GETFILEINFO OTHERFILE
                                                                             'IWRITEDATE))
                                                       (< DT OTHERWDT)))
                                              (OR (NULL FILTER)
                                                  (CL:FUNCALL FILTER NEXT OTHERFILE DT OTHERDT 
                                                         OTHERWDT GEN)))
                              |collect| (|if| (NOT DIRPRINTED)
                                                |then| (|printout| T T "   " THISDIR 18 
                                                                  "This Date" 38 "Other Date" 58 
                                                                  "Author" T)
                                                      (SETQ DIRPRINTED T))
                                    (|printout| T (SUBSTRING NEXT
                                                         (STRPOS THISDIR NEXT 1 NIL T T 
                                                                UPPERCASEARRAY))
                                           18
                                           (GDATE DT)
                                           38
                                           (GDATE OTHERDT)
                                           58)
                                    (|if| OTHERWDT
                                        |then| (|printout| T (GDATE OTHERWDT)
                                                          " "))
                                    (|printout| T (GETFILEINFO OTHERFILE 'AUTHOR)
                                           T)
                                    (FILENAMEFIELD NEXT 'NAME)))))))
+
+(NEWERSOURCES?
  (LAMBDA (DIRPAIRS FILTER)                              (* \; "Edited  9-Dec-86 23:07 by bvm")
    (OR DIRPAIRS (SETQ DIRPAIRS '(({ERIS}<LISPCORE>NEWSTRING>SOURCES> {ERIS}<LISPCORE>SOURCES>)
                                  ({ERIS}<LISPCORE>NEWSTRING>LIBRARY> {ERIS}<LISPCORE>LIBRARY>)
                                  ({ERIS}<LISPCORE>NEWSTRING>INTERNAL>LIBRARY> 
                                         {ERIS}<LISPCORE>INTERNAL>LIBRARY>))))
    (|for| PAIR |in| DIRPAIRS
       |do| (RESETLST
                    (LET ((THISDIR (CAR PAIR))
                          (OTHERDIR (CADR PAIR))
                          NEXT DT THISFILE THISDT WDT DIRPRINTED GEN)
                         (SETQ GEN (\\GENERATEFILES (PACKFILENAME.STRING 'DIRECTORY OTHERDIR
                                                           'NAME "*" 'VERSION "")
                                          '(ICREATIONDATE IWRITEDATE AUTHOR)
                                          '(RESETLST)))
                         (|while| (SETQ NEXT (\\GENERATENEXTFILE GEN))
                            |eachtime| (SETQ THISDT (SETQ WDT (SETQ DT NIL)))
                            |when| (AND (SETQ DT (\\GENERATEFILEINFO GEN 'ICREATIONDATE))
                                            (OR (NULL (SETQ THISFILE (INFILEP (PACKFILENAME.STRING
                                                                               'DIRECTORY THISDIR
                                                                               'EXTENSION COMPILE.EXT
                                                                               'VERSION NIL
                                                                               'BODY NEXT))))
                                                (AND (SETQ THISDT (GETFILEINFO THISFILE 
                                                                         'ICREATIONDATE))
                                                     (OR (> DT THISDT)
                                                         (AND (SETQ WDT (\\GENERATEFILEINFO
                                                                         GEN
                                                                         'IWRITEDATE))
                                                              (> WDT THISDT)))))
                                            (OR (NULL FILTER)
                                                (CL:FUNCALL FILTER NEXT THISFILE DT WDT THISDT GEN)))
                            |do| (|if| (NOT DIRPRINTED)
                                         |then| (|printout| T T "   " OTHERDIR 18 " Its Date" 38
                                                           " Other Date" 58 "Author" T)
                                               (SETQ DIRPRINTED T))
                                  (OR (GET (NAMEFIELD NEXT)
                                           'FILEDATES)
                                      (PRIN1 "+" T))
                                  (|printout| T (SUBSTRING NEXT
                                                       (STRPOS OTHERDIR NEXT 1 NIL T T UPPERCASEARRAY
                                                              ))
                                         18
                                         (GDATE DT)
                                         38
                                         (|if| THISDT
                                             |then| (GDATE THISDT)
                                           |else| " - - -")
                                         58)
                                  (|if| WDT
                                      |then| (|printout| T (GDATE WDT)
                                                        " "))
                                  (|printout| T (\\GENERATEFILEINFO GEN 'AUTHOR)
                                         T)))))))
+
+(SETUP-FOR-RECOMPILE
  (LAMBDA NIL                                            (* \; "Edited  8-Dec-86 21:23 by jop:")
                                                             (* \; 
                                                           "So we don't get alot of warnings")
    (SETQ *REMOVE-INTERLISP-COMMENTS* NIL)                   (* \; 
                                                           "So we don't get asked stupid questions")
    (SETQ CROSSCOMPILING T)                                  (* \; 
                                                           "setup up new compiled file version")
    (PUTPROP ':D4 'CODEREADER (COPYALL (GETPROP 'D1 'CODEREADER)))
    (RPAQQ CODEINDICATOR :D4)
    (RPAQQ COMPILE.EXT LCOM)                             (* \; 
                                                           "Smash garbage collectable opcodes")
    (SMASH-OPCODES GARBAGE-OPCODES)                      (* \; "Setup for unwind recompile")
    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>UNWINDMACROS 'SYSLOAD)
                                                             (* \; "may not be necessary")
    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>PROC 'PROP)     (* \; "Setup for new string recompile")
    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>LLCHAR 'PROP)
    (REMPROP 'STRINGP 'DOPVAL)                               (* \; "to get correct record def's")
    (LOAD '{ERIS}<LISPCORE>SOURCES>CMLARRAY 'PROP)           (* \; "Setup for new stream record")
    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>FILEIO 'PROP)   (* \; 
                                                     "To setup packagified global type number vars")
    (LOAD '{ERIS}<LISPCORE>NEWSTRING>SOURCES>DTDECLARE.DCOM 'SYSLOAD)
                                                             (* \; 
                                              "hack for typep - not needed if makesysdate > Nov 23")
    (CL:DEFTYPE :DATATYPE (OBJECT)
       `(DATATYPE ,OBJECT))                                  (* \; "dribble hack")
    (WBREAK NIL)                                             (* \; "So the debuuger will compile")
    (LOAD '{ERIS}<LISPCORE>SOURCES>XCL-PACKAGE.DCOM)         (* \; "To fix the broken FP printer")
    (LOADFNS '\\CONVERT.FLOATING.NUMBER '{ERIS}<LISPCORE>SOURCES>LLFLOAT.DCOM)))
+
+(SMASH-OPCODES
  (LAMBDA (OPCODE-ALIST)                                 (* \; "Edited 24-Nov-86 17:56 by jop:")
    (LET (OPNUMBER)
         (CL:DOLIST (OPCODE OPCODE-ALIST)
             (SETQ OPNUMBER (CADR OPCODE))
             (CL:NSUBSTITUTE-IF (LIST OPNUMBER ':UNUSED)
                    (FUNCTION (CL:LAMBDA (OP)
                                     (EQL (CAR OP)
                                          OPNUMBER)))
                    \\OPCODES :COUNT 1)
             (SETQ \\OPCODEARRAY NIL)))))
+
+(GET-DIRECTORY-LISTING
  (LAMBDA (DIRECTORY EXTENSION)                          (* \; "Edited 24-Nov-86 18:14 by jop:")
    (|for| X |infiles| (DIRECTORY.FILL.PATTERN DIRECTORY (OR EXTENSION "")
                                      "") |collect| (FILENAMEFIELD X 'NAME))))
+
+(GET-OPEN-FILES
  (LAMBDA (DEVICE-NAME)                                  (* \; "Edited 25-Nov-86 18:16 by jop:")
    (FETCH (FDEV OPENFILELST) OF (CDR (ASSOC DEVICE-NAME \\DEVICENAMETODEVICE)))))
+)
+
+
+
+(* |;;| "Control variables")
+
+
+(RPAQQ FILES-IN-FULL.SYSOUT
+       (PACKAGE-STARTUP LLPACKAGE LLSYMBOL CMLARRAY CMLLIST CMLMACROS DMISC COMPATIBILITY APUTDQ 
+              LLDISPLAY FONT PASSWORDS LEAF PUP LLETHER PROC ERROR-RUNTIME DEFSTRUCT-RUN-TIME 
+              BOOTSTRAP MISC AINTERRUPT AERROR ABASIC APRINT ATERM MOD44IO VANILLADISK PMAP ADIR AOFD
+              COREIO IOCHAR LLCODE ATBL DTDECLARE ASTACK LLTIMER LLKEY LLDATATYPE LLSTK LLCHAR LLREAD
+              LLBIGNUM LLFLOAT LLARITH LLARRAYELT LLMVS LLINTERP LLGC LLBASIC IMAGEIO FILEIO LLNEW 
+              LLBFS LLSUBRS LLFAULT PACKAGE-CONVERSION-TABLE ACODE MACHINEINDEPENDENT POSTLOADUP 
+              DEFPACKAGE-IMPORT XCL-PACKAGE LISP-PACKAGE FASL-PACKAGE COMPILER-PACKAGE BSP DPUPFTP 
+              CMLCHARACTER CMLREADTABLE STACKFNS CMLMVS MACROS MACROAUX CMLSYMBOL CMLHASH CMLDEFFER 
+              CMLPROGV CMLEVAL COMMON CMLSPECIALFORMS CONDITION-HIERARCHY XCLC-RUNTIME CMLTYPES 
+              CL-ERROR AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN 
+              ADVISE LOADFNS DIRECTORY FILEPKG RESOURCE DLAP BYTECOMPILER COMPILE HIST UNDO SPELL 
+              DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST ASKUSER CMLUNDO CMLEXEC DEBUGGER TRACE
+              CMLDOC CMLPARSE CMLSETF CMLPRED CMLARRAY-OPTIMIZERS CMLREAD CMLWALK CMLSEQCOMMON 
+              CMLSEQBASICS CMLSEQMAPPERS CMLSEQMODIFY CMLSEQFINDER CMLSORT CMLSEQ CMLARITH DEFSTRUCT
+              CMLMISCIO CMLCOMPILE CMLSTRING CLSTREAMS CMLDESTRUCT CMLFORMAT CMLENVIRONMENT CMLPRINT
+              CMLLOAD CMLFILESYS CMLFLOAT CMLTIME CMLRAND CMLMODULES ADDARITH READ-PRINT-PROFILE 
+              CMLPATHNAME HPRINT MSANALYZE MSPARSE MASTERSCOPE AARITH ADISPLAY HLDISPLAY MENU 
+              WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT 
+              TWODINSPECTOR FREEMENU CMLARRAYINSPECTOR EDITINTERFACE TTYIN DISKDLION DOVEINPUTOUTPUT
+              DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY 10MBDRIVER LLNS
+              TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS FLOPPY IDLER 
+              ICONW SEDIT-ATOMIC SEDIT-COMMANDS SEDIT-COMMENTS SEDIT-LINEAR SEDIT-LISTS 
+              SEDIT-TERMINAL SEDIT-TOPLEVEL SEDIT-WINDOW SEDIT D-ASSEM-PACKAGE D-ASSEM FASL 
+              XCLC-READER XCLC-ENV-CTXT XCLC-TREES XCLC-TOP-LEVEL XCLC-ALPHA XCLC-ANALYZE 
+              XCLC-META-EVAL XCLC-ANNOTATE XCLC-GENCODE XCLC-PEEPHOLE XCLC-DATABASE XCL-COMPILER 
+              CMLPACKAGE GIVE-AND-TAKE CHATTERMINAL DMCHAT CHAT PUPCHAT NSCHAT PRESS PUPPRINT 
+              TEDITDECLS TEXTOFD TEDITCOMMAND TEDITSCREEN TEDITABBREV TEDITLOOKS TEDITFIND 
+              TEDITHISTORY TEDITFILE TEDITWINDOW TEDITSELECTION READNUMBER EDITBITMAP IMAGEOBJ 
+              TFBRAVO TEDITHCPY TEDITPAGE TEDITMENU TEDITFNKEYS TEDIT HRULE TEDITCHAT GRAPEVINE 
+              MAILCLIENT NSMAIL LAFITEBROWSE LAFITESEND LAFITEMAIL LAFITE TABLEBROWSER FILEBROWSER 
+              REMOTEVMEM VMEM READSYS RDSYS TELERAID GRAPHER SPY AREDIT HASH WHEREIS COPYFILES))
+
+(RPAQQ FILES-IN-LIBRARY
+       (4045XLPDEFAULTPRINTER 4045XLPSTREAM ARCLEANUP AREDIT BROWSER BSEARCH CENTRONICS 
+              CHARCODETABLES CHAT CHATDECLS CHATTERMINAL CLMAIL CML CMLARRAYINSPECTOR CMLDEBUGGER 
+              CMLFLOATARRAY CMLHELP COLOR COLORDEMO CONDITIONGRAPH COPYFILES DANDELIONKEYBOARDS 
+              DATABASEFNS DAYBREAKKEYBOARDS DEDIT DES DICOLOR DINFO DLRS232C DLTTY DMCHAT DO-TEST 
+              DORADOCOLOR DORADOKEYBOARDS DOVEKEYBOARDS DOVERS232C DSKTEST EDITBITMAP ETHERRECORDS 
+              FASTFX80STREAM FILEBROWSER FILECACHE FILECACHE-BROWSER FILECACHE-DECLS FILECACHE-HOSTUP
+              FILECACHE-SCAVENGE FILENAMES FONTSAMPLE FTPSERVER FX80STREAM FXPRINTER GCHAX 
+              GIVE-AND-TAKE GRAPEVINE GRAPHER GRAPHZOOM HASH HELPSYS HRULE IMAGEOBJ KERMIT KERMITMENU
+              KEYBOARDEDITOR LAFITE LAFITEBROWSE LAFITEDECLS LAFITEFIND LAFITEMAIL LAFITESEND 
+              LAMBDATRAN LISPDIAGNOSTICS LLCOLOR MACROTEST MACROTESTAUX MAILCLIENT MAILSCAVENGE 
+              MAINTAIN MATMULT MERGE-FILEGEN MESATYPES MINISERVE MSHASH NEWDEBUG NSCHAT NSCHATSERVER
+              NSMAIL NSMAINTAIN NSTOASCIIDISPLAYFONT PCALLSTATS PCE PCEDISPLAY PCEERD PCEFLOPPY 
+              PCEKEYBOARD PCEWINDOW PCMEMTEST PIXELBLT PUPCHAT PUPIDSERVER RDSYS READAIS READNUMBER 
+              READSYS REMOTEVMEM RS232CHAT RS232CHATSERVER RS232CMENU SAMEDIR SCALEBITMAP SFFONT 
+              SIMPLIFY SKETCHCOLOR SKETCHSTREAM SPY SYSEDIT TABLEBROWSER TABLEBROWSERDECLS TCP 
+              TCPCHAT TCPCONFIG TCPDEBUG TCPFTP TCPHTE TCPLLAR TCPLLICMP TCPLLIP TCPNAMES TCPTFTP 
+              TCPUDP TEDIT TEDITABBREV TEDITCHAT TEDITCOLOR TEDITCOMMAND TEDITDECLS TEDITFILE 
+              TEDITFIND TEDITFNKEYS TEDITHCPY TEDITHISTORY TEDITKEY TEDITLOOKS TEDITMENU TEDITPAGE 
+              TEDITPAGINATE |TEditPartOne| |TEditPartTwo| TEDITSCREEN TEDITSELECTION TEDITWINDOW 
+              TEK4010 TEK4010CHAT TELERAID TEXEC TEXTOFD TFBRAVO TTYCHAT TWODINSPECTOR 
+              VIRTUALKEYBOARDS VMEM VPCDISK VT100KP VTCHAT WHEREIS 4045STREAM BUSCOLOR BUSEXTENDER 
+              BUSMASTER BUSMASTERARRAYBASE BUSTEST C150STREAM COLORNNCC COLOROBJ COLORPOLYGONS 
+              DANDELIONUFO DANDELIONUFO4096 IRISCONSTANTS IRISIO IRISLIB IRISNET IRISSTREAM LOADIRIS))
+
+(RPAQQ FILES-IN-LISP.SYSOUT
+       (PACKAGE-STARTUP LLPACKAGE LLSYMBOL CMLARRAY CMLLIST CMLMACROS DMISC COMPATIBILITY APUTDQ 
+              LLDISPLAY FONT PASSWORDS LEAF PUP LLETHER PROC ERROR-RUNTIME DEFSTRUCT-RUN-TIME 
+              BOOTSTRAP MISC AINTERRUPT AERROR ABASIC APRINT ATERM MOD44IO VANILLADISK PMAP ADIR AOFD
+              COREIO IOCHAR LLCODE ATBL DTDECLARE ASTACK LLTIMER LLKEY LLDATATYPE LLSTK LLCHAR LLREAD
+              LLBIGNUM LLFLOAT LLARITH LLARRAYELT LLMVS LLINTERP LLGC LLBASIC IMAGEIO FILEIO LLNEW 
+              LLBFS LLSUBRS LLFAULT PACKAGE-CONVERSION-TABLE ACODE MACHINEINDEPENDENT POSTLOADUP 
+              DEFPACKAGE-IMPORT XCL-PACKAGE LISP-PACKAGE FASL-PACKAGE COMPILER-PACKAGE BSP DPUPFTP 
+              CMLCHARACTER CMLREADTABLE STACKFNS CMLMVS MACROS MACROAUX CMLSYMBOL CMLHASH CMLDEFFER 
+              CMLPROGV CMLEVAL COMMON CMLSPECIALFORMS CONDITION-HIERARCHY CONDITION-HIERARCHY-SI 
+              CONDITION-HIERARCHY-POST-SI CONDITION-HIERARCHY-IL XCLC-RUNTIME CMLTYPES CL-ERROR AFONT
+              EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN ADVISE LOADFNS 
+              DIRECTORY FILEPKG RESOURCE DLAP BYTECOMPILER COMPILE HIST UNDO SPELL DWIM WTFIX CLISP 
+              DWIMIFY CLISPIFY RECORD ASSIST ASKUSER CMLUNDO CMLEXEC DEBUGGER TRACE CMLDOC CMLPARSE 
+              CMLSETF CMLPRED CMLARRAY-OPTIMIZERS CMLREAD CMLWALK CMLSEQCOMMON CMLSEQBASICS 
+              CMLSEQMAPPERS CMLSEQMODIFY CMLSEQFINDER CMLSORT CMLSEQ CMLARITH DEFSTRUCT CMLMISCIO 
+              CMLCOMPILE CMLSTRING CLSTREAMS CMLDESTRUCT CMLFORMAT CMLENVIRONMENT CMLPRINT CMLLOAD 
+              CMLFILESYS CMLFLOAT CMLTIME CMLRAND CMLMODULES ADDARITH READ-PRINT-PROFILE CMLPATHNAME
+              HPRINT MSANALYZE MSPARSE MASTERSCOPE AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ 
+              WINDOWSCROLL WINDOW WINDOWICON ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT TWODINSPECTOR
+              FREEMENU CMLARRAYINSPECTOR EDITINTERFACE TTYIN DISKDLION DOVEINPUTOUTPUT DOVEDISK 
+              DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY 10MBDRIVER LLNS TRSERVER
+              SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS FLOPPY IDLER ICONW 
+              SEDIT-ATOMIC SEDIT-COMMANDS SEDIT-COMMENTS SEDIT-LINEAR SEDIT-LISTS SEDIT-TERMINAL 
+              SEDIT-TOPLEVEL SEDIT-WINDOW SEDIT D-ASSEM-PACKAGE D-ASSEM FASL XCLC-READER 
+              XCLC-ENV-CTXT XCLC-TREES XCLC-TOP-LEVEL XCLC-ALPHA XCLC-ANALYZE XCLC-META-EVAL 
+              XCLC-ANNOTATE XCLC-GENCODE XCLC-PEEPHOLE XCLC-DATABASE XCL-COMPILER CMLPACKAGE))
+
+(RPAQQ FILES-IN-SOURCES
+       (ADVISE AFONT BREAK-AND-TRACE CL-ERROR CLOSURE-CACHE CMLDEFFER CMLENVIRONMENT CMLPACKAGE 
+              CMLSETF CMLSMARTARGS CMLUNDO DEBUGGER DEFSTRUCT DESCRIBE ERROR-RUNTIME-AFTER-FASL 
+              FASDUMP HPRINT IMPLICIT-KEY-HASH SEDIT-ACCESS SEDIT-ATOMIC SEDIT-BASE SEDIT-COMMANDS 
+              SEDIT-COMMENTS SEDIT-EXPORTS SEDIT-INDENT SEDIT-LINEAR SEDIT-LIST-FORMATS SEDIT-LISTS 
+              SEDIT-TERMINAL SEDIT-TOPLEVEL SEDIT-WINDOW SEDIT WALKER XCL-EXTRAS XCLC-DATABASE 
+              XCLC-OPTIMIZERS XCLC-TOP-LEVEL XCLC-TREES 10MBDRIVER AARITH ABASIC ACODE ADDARITH ADIR
+              ADISPLAY AERROR AINTERRUPT AOFD APRINT APUTDQ ARGLIST ASKUSER ASTACK ATBL ATERM 
+              ATTACHEDWINDOW AUTHENTICATION NSFILING BOOTSTRAP BSP BYTECOMPILER CLEARINGHOUSE CLISP 
+              CLISPIFY CLSTREAMS CMLARITH CMLARRAY-SUPPORT CMLARRAY CMLARRAYINSPECTOR CMLCHARACTER 
+              CMLCOMPILE CMLDESTRUCT CMLDOC CMLEVAL CMLEXEC CMLFILESYS CMLFLOAT CMLFORMAT CMLHASH 
+              CMLLIST CMLLOAD CMLMACROS CMLMISCIO CMLMODULES CMLMVS CMLPARSE CMLPATHNAME CMLPRED 
+              CMLPRINT CMLPROGV CMLRAND CMLREAD CMLREADTABLE CMLSEQ CMLSEQBASICS CMLSEQCOMMON 
+              CMLSEQFINDER CMLSEQMAPPERS CMLSEQMODIFY CMLSORT CMLSPECIALFORMS CMLSTEP CMLSTRING 
+              CMLSYMBOL CMLTIME CMLTYPES COMMON COMPARE COMPATIBILITY COMPILE COMPILER-PACKAGE 
+              CONDITION-HIERARCHY-IL CONDITION-HIERARCHY-POST-SI CONDITION-HIERARCHY-SI 
+              CONDITION-HIERARCHY CONDITION-PACKAGE COREIO COROUTINE COURIER D-ASSEM-PACKAGE D-ASSEM
+              DEBUGEDIT DEFFER-RUNTIME DEFPACKAGE-IMPORT DEFSTRUCT-RUN-TIME DEXEC DIRECTORY DISKDLION
+              DLAP DLFIXINIT DMISC DOVEDISK DOVEDISPLAY DOVEETHER DOVEFLOPPY DOVEINPUTOUTPUT DOVEMISC
+              DPUPFTP DSKDISPLAY DSPRINTDEF DTDECLARE DWIM DWIMIFY EDIT EDITINTERFACE ERROR-RUNTIME 
+              EXEC-COMMANDS FASL-PACKAGE FASLOAD FILEIO FILEPKG FLOPPY FONT FONTPROFILE FREEMENU 
+              GAINSPACE HARDCOPY HIST HLDISPLAY ICONW IDLER IL-ERROR-STUFF IMAGEIO INSPECT-CLOSURE 
+              INSPECT INTERPRESS IOCHAR LEAF LISP-PACKAGE CMLWALK DEBUGGER-EVAL DOVEVMEMSIZEPATCH 
+              SEDIT-CONVERT SEDIT-DEBUG SEDIT-LOAD LLARITH LLARRAYELT LLBASIC LLBFS LLBIGNUM LLCHAR 
+              LLCODE LLDATATYPE LLDISPLAY LLERROR LLETHER LLFAULT LLFLOAT LLGC LLINTERP LLKEY LLMVS 
+              LLNEW LLNS LLPACKAGE LLREAD LLRESTART LLSTK LLSUBRS LLSYMBOL LLTIMER LOADFNS LOCALFILE
+              LOGOW LYRIC-PATCH-1 MACHINEINDEPENDENT MACROAUX MACROS MAKEINIT MEM MENU MISC MOD44IO 
+              NEWPRINTDEF NSPRINT PACKAGE-CONVERSION-TABLE PACKAGE-STARTUP PAINTW PASSWORDS PMAP 
+              POSTLOADUP PRETTY PRINTFN PROC PROFILE PUP READ-PRINT-PROFILE RECORD RENAMEFNS RESOURCE
+              SETF-RUNTIME SPELL SPELLFILE SPP STACKFNS SYSPRETTY TIME TRSERVER TTYIN TWODINSPECTOR 
+              UNDO UNWINDMACROS VANILLADISK WEDIT WINDOW WINDOWICON WINDOWOBJ WINDOWSCROLL WRAPPERS 
+              WTFIX XCL-COMPILER XCL-PACKAGE XCLC-ALPHA XCLC-ANALYZE XCLC-ANNOTATE XCLC-ENV-CTXT 
+              XCLC-GENCODE XCLC-META-EVAL XCLC-PEEPHOLE XCLC-RUNTIME XCLC-TRANSFORMS XXFILL XXGEOM))
+
+(RPAQQ FORKED-FILES (ABC APUTDQ ASTACK CMLEVAL CMLMVS DEFPACKAGE-IMPORT DLAP DTDECLARE DWIMIFY 
+                             FILEIO FILESETS LLBASIC LLCHAR LLCODE LLDATATYPE LLINTERP LLNEW LLSTK 
+                             MACHINEINDEPENDENT MACROS MISC PACKAGE-STARTUP PROC UNWINDMACROS 
+                             XCL-PACKAGE))
+
+(RPAQQ GARBAGE-OPCODES
+       ((BOUT 33)
+        (DOCOLLECT 36)
+        (ENDCOLLECT 37)
+        (GETP 27)
+        (GETHASH 29)
+        (ELT 40)
+        (NTHCHC 41)
+        (SETA 42)
+        (RPLCHARCODE 43)
+        (EVALV 45)
+        (ATOMNUMBER 112)
+        (GETBASEFIXP.N 203)
+        (PUTBASEFIXP.N 204)))
+
+
+
+(* \; "Utilities for making mass-scale fixups to a library of files.")
+
+(DEFINEQ
+
+(FIX-FILES
  (CL:LAMBDA (FILENAMES SOURCEDIR DESTDIR &OPTIONAL (DRIBBLE-FILE '{DSK6}BIGCOMP.DRIBBLE)
                    DELETE-DRIBBLE? RECORDS-TO-FIX)      (* \; "Edited 15-Aug-90 12:02 by jds")

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

         (CL:BLOCK FIX-FILES
             (LET ((COMPLETION 'ERROR)
                   (NUM-FILES (LENGTH FILENAMES)))
                  (IDLE.SET.OPTION 'TIMEOUT T)
                  (SETQ NOSPELLFLG T)
                  (SETQ DWIMIFYCOMPFLG NIL)
                  (CL:UNWIND-PROTECT
                      (PROGN (DRIBBLE DRIBBLE-FILE)
                             (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM))
                                    'PAGEFULLFN
                                    'NILL)
                             (CNDIR DESTDIR)
                             (PRINTOUT NIL "= = = = = Setting up for large-scale fix-up run on "
                                    (DATE)
                                    " = = = = =" T T)
                             (|for| FILE |in| FILENAMES |as| FILE-NUM |from| 1
                                |do| (DSPNEWPAGE (GETSTREAM NIL 'OUTPUT))
                                      (LET* ((SOURCEFILE (PACKFILENAME 'BODY FILE 'DIRECTORY 
                                                                SOURCEDIR))
                                             (DESTFILE (PACKFILENAME 'BODY FILE 'DIRECTORY DESTDIR)))
                                            (RESETLST
                                                (PRINTOUT NIL T "Fixing file " SOURCEFILE " at "
                                                       (DATE)
                                                       " - - -" T)
                                                (PRINTOUT NIL T "(File number " FILE-NUM " of " 
                                                       NUM-FILES ": " (- NUM-FILES FILE-NUM)
                                                       " left)" T T)
                                                (PRINT (FIX-FILE FILE RECORDS-TO-FIX)
                                                       T)
                                                (PRINTOUT NIL T T "- - - End of " FILE 
                                                       " fix-up - - -" T))))
                             (PRINTOUT NIL T T T "= = = = = END OF CLEANUP RUN = = = = =")
                             (SETQ COMPLETION 'SUCCESS))
                      (PRINTOUT NIL T "Fix-up status: " COMPLETION T T)
                      (DRIBBLE)
                      (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM))
                             'PAGEFULLFN NIL))
                  (SEND.FILE.TO.PRINTER DRIBBLE-FILE)
                  (AND DELETE-DRIBBLE? (DELFILE DRIBBLE-FILE))))))
+
+(FIX-FILE
  (LAMBDA (FILE RECORD-NAMES MAKEFILE-ONLY?)             (* \; "Edited 21-Jan-93 16:30 by jds")

    (* |;;| "Perform cleanup tasks on FILE.")

    (LOAD FILE 'PROP)
    (LOADCOMP FILE 'PROP)

    (* |;;| "(FIX-COPYRIGHT FILE)")

    (AND (FILEFNSLST FILE)
         (|for| RECNAME |in| (APPEND (FILECOMSLST FILE 'RECORDS)
                                            RECORD-NAMES) |do| (QUALIFY-FIELDS RECNAME FILE))
         )
    (MARKASCHANGED FILE 'FILES)
    (COND
       (MAKEFILE-ONLY? (MAKEFILE FILE))
       (T (APPLY* 'CLEANUP FILE)))))
+
+(FIX-COPYRIGHT
  (LAMBDA (FILENAME)
    (LET ((CR (GETPROP FILENAME 'COPYRIGHT)))
         (COND
            (CR (RPLACA CR "Venue & Xerox Corporation"))
            (T (PUTPROP FILENAME 'COPYRIGHT (LIST "Venue" 1990)))))))
+
+(FIX-FILE-COPYRIGHT
  (LAMBDA (FILE)
    (LOADFROM FILE NIL 'PROP)
    (FIX-COPYRIGHT FILE)
    (MARKASCHANGED FILE 'FILES)
    (APPLY* 'CLEANUP FILE)))
+
+(QUALIFY-FIELDS
  (LAMBDA (RECNAME FILE)                                 (* \; "Edited 28-Sep-87 14:41 by bvm:")
    (APPLY* 'EDITFNS FILE `(LPQ F ((*ANY* FETCH |fetch| REPLACE |replace| FFETCH |ffetch| FREPLACE 
                                          |freplace| /REPLACE |/replace|)
                                   (*ANY* ,@(APPEND (RECORDFIELDNAMES RECNAME)))
                                   --)
                                2
                                (MBD ,RECNAME)
                                0 P))))
+
+(FIX-TEDIT
  (LAMBDA (FILE)                                         (* \; "Edited 17-Aug-90 16:07 by jds")
    (LET ((STRM (OPENTEXTSTREAM (MKATOM FILE))))
         (TEDIT.SUBLOOKS STRM '(FAMILY OPTIMA)
                '(FAMILY CLASSIC))
         (TEDIT.PUT STRM FILE)
         (CLOSEF STRM))))
+
+(FIX-DOCS
  (LAMBDA (DIRECTORY)
    (LET ((FILES (|for| FILE |in| (DIRECTORY (CONCAT DIRECTORY "*.TEDIT;"))
                    |collect| (PACKFILENAME.STRING 'VERSION NIL 'BODY FILE))))
         (|for| FILE |in| FILES |do| (FIX-TEDIT FILE)))))
+)
+
+
+
+(* |;;| 
+"Removes bogus (CLISP  <clisp xlation> <real-code>) translations that result from CLISPARRAY being NIL."
+)
+
+(DEFINEQ
+
+(CLFIX
+  (LAMBDA (FILE)                                         (* \; "Edited  9-Sep-94 11:57 by jds")
+    (APPLY* 'EDITFNS FILE '(LPQ F CLISP\  1 D D 0 P))))
+)
+
+(PUTPROPS MULTI-COMPILE FILETYPE CL:COMPILE-FILE)
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA FIX-FILES)
+)
+(PUTPROPS MULTI-COMPILE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990 1991 1992 1993 1994))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (7131 8389 (FIND-UNCOMPILED-FILES 7141 . 8387)) (8461 19787 (NEWERDCOMS? 8471 . 12445) (
+NEWERSOURCES? 12447 . 16359) (SETUP-FOR-RECOMPILE 16361 . 18749) (SMASH-OPCODES 18751 . 19269) (
+GET-DIRECTORY-LISTING 19271 . 19568) (GET-OPEN-FILES 19570 . 19785)) (31690 36610 (FIX-FILES 31700 . 
+34497) (FIX-FILE 34499 . 35090) (FIX-COPYRIGHT 35092 . 35319) (FIX-FILE-COPYRIGHT 35321 . 35481) (
+QUALIFY-FIELDS 35483 . 36022) (FIX-TEDIT 36024 . 36330) (FIX-DOCS 36332 . 36608)) (36735 36917 (CLFIX 
+36745 . 36915)))))
+STOP
diff --git a/internal/library/NATIVE-TRANSLATOR b/internal/library/NATIVE-TRANSLATOR
new file mode 100644
index 00000000..d1c0b52b
--- /dev/null
+++ b/internal/library/NATIVE-TRANSLATOR
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "NATIVE-TRANSLATOR")
(FILECREATED "24-Jun-88 16:37:57" 
|{POGO:AISNORTH:XEROX}<DSUNUNIX>KRIVACIC>TRANSLATOR>NATIVE-TRANSLATOR.;82| 195538 

      |changes| |to:|  (FNS MAKE-OPCODE-LIST MAKE-ORDERING-LIST ADD-FN-HEADER-INFO FN-CALL-PARSER 
                            IL:LINK-OBJECT-CODE PVAR_PARSER MAKE-VAR-OFFSETS IL-ADD-FN-HEADER-INFO)
                       (VARS IL:NATIVE-TRANSLATORCOMS)
                       (FUNCTIONS CODEBASELT2 CODEBASELT)

      |previous| |date:| "22-Jun-88 19:17:38" 
IL:|{POGO:AISNORTH:XEROX}<DSUNUNIX>KRIVACIC>TRANSLATOR>NATIVE-TRANSLATOR.;65|)


; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT IL:NATIVE-TRANSLATORCOMS)

(RPAQQ IL:NATIVE-TRANSLATORCOMS
       ((RECORDS BYTE-INFO-REC TRANSLATION-REC INFO-REC NATIVE-LINKER-INFO LINE-INFO-REC 
               LINE-RECORD-INFO)
        

(* |;;;| "Interface Functions ")

        (FNS BYTE-TO-NATIVE-TRANSLATE NATIVE-TO-BYTE-UNTRANSLATE IL:LINK-OBJECT-CODE)
        (FNS NBT NATIVE-TRANS NATIVE-TRANSLATE)
        (FNS NUT FETCH-GCONST)
        (FNS LINK-C-CODE LINK-FN-CODE-BLOCK UNPACK-NUMBER)
        
        (* |;;| "Pass 1 Functions")

        (FNS CODEWALK1 SETJUMPTARGET)
        (FUNCTIONS GETBYTE)
        
        (* |;;| "Pass 2 Functions ")

        (FNS CODEWALK2 CONDITIONAL-PARSER INLINE-EXPAND)
        
        (* |;;| "Parsing Functions")

        (FNS BCE-PARSER STR-PARSER COND-PARSER CONST-PARSER COPY-PARSER JUMP-PARSER FN-CALL-PARSER 
             FN-CALL-PARSERX ENVCALL-PARSER RETURN-PARSER SWAP-PARSER PVAR_PARSER)
        
        (* |;;| "Pattern Matching  Routines")

        (FNS PARM-SUBSTITUTE TOS-CHECK)
        
        (* |;;| "Output of Code lines")

        (FNS ADD-CASE ADD-PUSH-OPERAND-LINE ADD-FN-HEADER-INFO IL-ADD-FN-HEADER-INFO 
             CL-ADD-FN-HEADER-INFO)
        
        (* |;;| "Low Level Output of  code lines")

        (FNS ADD-LINE ADD-OPERAND-LINE ADD-LF ADD-ASM-LINE ADD-INLINE-LINE BCE-LINE)
        
        (* |;;| "Error Line Functions")

        (FNS ADD-ERROR-LINE ADD-ERROR-ENTRY ADD-ERROR-SELECT)
        
        (* |;;| "Low Level Routines")

        (FNS FIX-FILENAME PC-XFORM BCE-PC ENVCALL-FN-OBJECT FIND-FN0-OBJECTS CONST-POINTERP 
             MAKE-VAR-OFFSETS)
        
        (* |;;| "Deferred Stack Funcions")

        (FNS NEXT-OPERAND PUSH-ALL-OPERANDS OPERAND-PUSH OPERAND-GET OPERAND-POP GET-VAL 
             GET-SHIFTED-VAL GET-INFO ADD-INFO SET-INFO)
        
        (* |;;| "Writeout Files")

        (FNS MAKE-PROGRAM-FILE WRITE-PROGRAM-FILE WRITE-INLINE-FILE WRITE-INCLUDE-FILE 
             PRINT-CODE-LINE PRINT-LINE-INFO)
        
        (* |;;| "Initialization")

        (FNS TRANSLATION-INIT STRIP-ENDING-SLASH SETUP-TRANSLATION-FNS MAKE-TRANSLATION-ENTRY 
             MAKE-TRANSLATION-ENTRIES MAKE-TRANSLATION-PATTERN-LIST MAKE-INLINE-LISTS 
             MAKE-OPCODE-LIST MAKE-ORDERING-LIST)
        
        (* |;;| "Opcode Verification Fns")

        (FNS VERIFY-OPCODES VERIFY-OPCODE)
        
        (* |;;| "New Code Block Fns")

        (FNS LOADNATIVE GET-NATIVE-LOAD-SIZE LOAD-NATIVE-FILE SET-CODE-BASE MAKE-NEW-CODE-BLOCK 
             SET-NEW-FUNCTION-DEF GET-FUNCTION-DEF SET-NATIVE-ADDR GET-NATIVE-ADDR 
             LISP-ADDR-TO-NATIVE-ADDR NATIVE-ADDR-WORD-OFFSET WALK-CODE CODE-BLOCK-COPY ADD-GCONST 
             MAKE-PC-OFFSET)
        
        (* |;;| "UNIX Exec Functions")

        (FNS DO-EXEC-COMMAND TRAN-END-OF-UNIX-STREAM)
        
        (* |;;| "Macros")

        (FUNCTIONS SWAPPED-FN-OBJ FN-OBJ CODEBASELT CODEBASELT2)
        
        (* |;;| "Variables")

        (INITVARS (IL:*NATIVE-TEMP-FILE-DIRECTORY* "/tmp")
               (*NATIVE-INCLUDE-FILE-DIRECTORY* NIL)
               (*NATIVE-LISP-RUN-FILENAME* NIL)
               (IL:*NATIVE-BIN-DIRECTORY* "/bin")
               (*REMOVE-TEMP-NATIVE-FILES* T)
               (*UNIX-STREAMS* NIL)
               (*NATIVE-GCONST-OFFSET* 12)
               (*KEEP-NATIVE-SOURCES* NIL))
        
        (* |;;| "Makefile Environment")

        (PROP (FILETYPE MAKEFILE-ENVIRONMENT)
              NATIVE-TRANSLATOR)))
(DECLARE\: EVAL@COMPILE

(DATATYPE BYTE-INFO-REC 
          (PC OPCODE OPCODE-REC OP-NAME NEXT-BYTE-REC OPLENGTH JUMP-TARGET NEGATIVE-JUMP-TARGET 
              JUMP-TO-ADDRESS ARG1 ARG2 ARG3 LEVEL-ADJUST STACK-EFFECT ENTRY-STACK-DEPTH 
              CURRENT-STACK-MAX CURRENT-START-LEVEL ENTRY-ADDRESS OPCODE-PROPS))

(DATATYPE TRANSLATION-REC (MAY-UFN STACK-ADJUST STACK-ARGS PUSHING-RESULT DEFER-PUSH PATTERN 
                                     TRANS-PATTERN TRANS-PARAMATERS PARSE-FN INLINE-EXIT-FN 
                                     INLINE-EXPANSIONS POPPING-TOS))

(RECORD INFO-REC (POP-COUNT INFO-TYPE))

(BLOCKRECORD NATIVE-LINKER-INFO ((MACHINE-TYPE BITS 16)
                                     (MAGIC BITS 16)
                                     (TEXT-SIZE BITS 32)
                                     (DATA-SIZE BITS 32)
                                     (BSS-SIZE BITS 32)
                                     (SYMBOL-SIZE BITS 32)
                                     (ENTRY-POINT BITS 32)
                                     (TEXT-RELOCATION-SIZE BITS 32)
                                     (DATA-RELOCATION-SIZE BITS 32))
                                    (ACCESSFNS (RECORD-SIZE (PROGN 32)))
                                    (CREATE (PROGN (\\ALLOCBLOCK 8 UNBOXEDBLOCK.GCT 8 
                                                              CELLSPERQUAD))))

(DATATYPE LINE-INFO-REC (PATTERN-LIST PARAMETER-LIST ACTUAL-PARAMETERS))

(DATATYPE LINE-RECORD-INFO (PREFIX-STRING LINE-INFO-LIST POSTFIX-STRING))
)

(/DECLAREDATATYPE 'BYTE-INFO-REC
       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
               POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)
       '((BYTE-INFO-REC 0 POINTER)
         (BYTE-INFO-REC 2 POINTER)
         (BYTE-INFO-REC 4 POINTER)
         (BYTE-INFO-REC 6 POINTER)
         (BYTE-INFO-REC 8 POINTER)
         (BYTE-INFO-REC 10 POINTER)
         (BYTE-INFO-REC 12 POINTER)
         (BYTE-INFO-REC 14 POINTER)
         (BYTE-INFO-REC 16 POINTER)
         (BYTE-INFO-REC 18 POINTER)
         (BYTE-INFO-REC 20 POINTER)
         (BYTE-INFO-REC 22 POINTER)
         (BYTE-INFO-REC 24 POINTER)
         (BYTE-INFO-REC 26 POINTER)
         (BYTE-INFO-REC 28 POINTER)
         (BYTE-INFO-REC 30 POINTER)
         (BYTE-INFO-REC 32 POINTER)
         (BYTE-INFO-REC 34 POINTER)
         (BYTE-INFO-REC 36 POINTER))
       '38)

(/DECLAREDATATYPE 'TRANSLATION-REC
       '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
               POINTER)
       '((TRANSLATION-REC 0 POINTER)
         (TRANSLATION-REC 2 POINTER)
         (TRANSLATION-REC 4 POINTER)
         (TRANSLATION-REC 6 POINTER)
         (TRANSLATION-REC 8 POINTER)
         (TRANSLATION-REC 10 POINTER)
         (TRANSLATION-REC 12 POINTER)
         (TRANSLATION-REC 14 POINTER)
         (TRANSLATION-REC 16 POINTER)
         (TRANSLATION-REC 18 POINTER)
         (TRANSLATION-REC 20 POINTER)
         (TRANSLATION-REC 22 POINTER))
       '24)

(/DECLAREDATATYPE 'LINE-INFO-REC '(POINTER POINTER POINTER)
       '((LINE-INFO-REC 0 POINTER)
         (LINE-INFO-REC 2 POINTER)
         (LINE-INFO-REC 4 POINTER))
       '6)

(/DECLAREDATATYPE 'LINE-RECORD-INFO '(POINTER POINTER POINTER)
       '((LINE-RECORD-INFO 0 POINTER)
         (LINE-RECORD-INFO 2 POINTER)
         (LINE-RECORD-INFO 4 POINTER))
       '6)



(* |;;;| "Interface Functions ")

(DEFINEQ

(IL:BYTE-TO-NATIVE-TRANSLATE
  (LAMBDA (FNS)                                          (* \; "Edited 10-Jun-88 14:33 by rtk")
    (NBT FNS)))

(IL:NATIVE-TO-BYTE-UNTRANSLATE
  (LAMBDA (FNS)                                          (* \; "Edited 10-Jun-88 14:39 by rtk")
    (NUT FNS)))

(IL:LINK-OBJECT-CODE
  (LAMBDA (FUNCTION-NAME OBJECT-FILE-NAME)
    (LINK-C-CODE FUNCTION-NAME OBJECT-FILE-NAME)))
)
(DEFINEQ

(NBT
  (LAMBDA (FUNCTION)                                     (* \; "Edited 15-Jun-88 15:09 by rtk")
    (COND
       ((NULL (AND IL:*NATIVE-INCLUDE-FILE-DIRECTORY* IL:*NATIVE-LISP-RUN-FILENAME*))
        (PRINTOUT T "You must setup: " T)
        (|if| (NULL IL:*NATIVE-INCLUDE-FILE-DIRECTORY*)
            |then| (PRINTOUT T "  IL:*NATIVE-INCLUDE-FILE-DIRECTORY*" T))
        (|if| (NULL IL:*NATIVE-LISP-RUN-FILENAME*)
            |then| (PRINTOUT T "  IL:*NATIVE-LISP-RUN-FILENAME*" T))
        (PRINTOUT T "before running the translator." T))
       ((LISTP FUNCTION)
        (LET ((RESULT-VALUE T))
             (|for| FN |in| FUNCTION |while| (SETQ RESULT-VALUE (NBT FN)))))
       (T (NATIVE-TRANS FUNCTION)))))

(NATIVE-TRANS
  (LAMBDA (|fn|)                                         (* \; "Edited 21-Jun-88 18:14 by rtk")
    (LET ((*FN-OBJECT-REMAP-LIST* NIL)
          (RE-TRANSLATE-LIST NIL)
          (TRANSLATE-RESULT NIL)
          (*NATIVE-STREAM* T)
          (|fn-to-translate| |fn|)
          |is-remapped-fn|)
         (DECLARE (SPECVARS *FN-OBJECT-REMAP-LIST* *NATIVE-STREAM*))
         (|repeatwhile| |fn-to-translate|
            |do| 

                  (* |;;| "Translate Next Fn")

                  (SETQ TRANSLATE-RESULT (NATIVE-TRANSLATE |fn-to-translate| T T
                                                (NEQ (MACHINETYPE)
                                                     'MAIKO))) 

                  (* |;;| "Check the Translation Results")

                  (|if| (LISTP TRANSLATE-RESULT)
                      |then| (|for| |fn-object-info| |in| TRANSLATE-RESULT
                                    |do| (|push| *FN-OBJECT-REMAP-LIST* (CONS 
                                                                                     |fn-object-info|
                                                                                      NIL)))
                            (|push| RE-TRANSLATE-LIST |fn-to-translate|)
                            (|for| |item| |in| TRANSLATE-RESULT |do| (|push| 
                                                                                    RE-TRANSLATE-LIST
                                                                                        |item|))
                    |elseif| (AND TRANSLATE-RESULT (SETQ |is-remapped-fn| (ASSOC 
                                                                                    |fn-to-translate|
                                                                                     
                                                                               *FN-OBJECT-REMAP-LIST*
                                                                                     )))
                      |then| (RPLACD |is-remapped-fn| TRANSLATE-RESULT))
                  (SETQ |fn-to-translate| (AND TRANSLATE-RESULT RE-TRANSLATE-LIST (|pop| 
                                                                                    RE-TRANSLATE-LIST
                                                                                         ))))
         TRANSLATE-RESULT)))

(NATIVE-TRANSLATE
  (LAMBDA (|fn| |make-the-file| |set-native| |keep-cr-eol|)
                                                             (* \; "Edited 21-Jun-88 20:51 by rtk")
    (DECLARE (SPECIAL *NATIVE-STREAM*))
    (LET (*ENTRY-POINTS* *CODE-BASE* *START-PC* *FN-NAME* *CODE-SIZE* *NUMBER-OF-ARGS* 
                *PVAR-QUAD-SIZE* *STACK-MIN-SIZE* *INLINES* *EVAL-STACK* *ERROR-STACK* *ERROR-CASES*
                *MATCHFOUND* *TRANSLATION-TABLE* *BYTE-INFO-TABLE* *ENTRY-ADDRS* (*ENTRY-POINT-MAX*
                                                                                  0)
                (*SHOW-INLINE* NIL)
                (*SHOW-BYTECODES* T)
                (*TARGET-MACHINE* 'SUN3)
                (*TARGET-MACHINE.N* 'SUN3.N)
                (|file-name| (FIX-FILENAME |fn|))
                (*GCONST-PTRS* NIL)
                PC-OFFSET OLD-CODE-BASE (*DEBUG-TRANSLATOR* (OR (NEQ 'MAIKO (MACHINETYPE))
                                                                (BOUNDP '*NATIVE-TRANSLATOR-DEBUG*)))
                (*SAW-ENVCALL* NIL)
                (*REPLACEMENT-STRING* NIL)
                (NEW-STKMIN NIL)
                (*VAR-OFFSETS* NIL)
                (GCONST-OFFSET *NATIVE-GCONST-OFFSET*))
         (DECLARE (SPECVARS *TARGET-MACHINE* *TARGET-MACHINE.N* *ENTRY-POINTS* *CODE-BASE* 
                             *START-PC* *FN-NAME* *CODE-SIZE* *NUMBER-OF-ARGS* *PVAR-QUAD-SIZE* 
                             *STACK-MIN-SIZE* *INLINES* *EVAL-STACK* *ERROR-STACK* *ERROR-CASES* 
                             *MATCHFOUND* *TRANSLATION-TABLE* *BYTE-INFO-TABLE* *SHOW-INLINE* 
                             *SHOW-BYTECODES* *ENTRY-ADDRS* *DEBUG-TRANSLATOR* *GCONST-PTRS* 
                             *ENTRY-POINT-MAX* *SAW-ENVCALL* *REPLACEMENT-STRING* *VAR-OFFSETS*))
         (|if| (NULL (FMEMB (MACHINETYPE)
                                '(MAIKO KATANA)))
             |then| (SETQ *NATIVE-TEMP-FILE-DIRECTORY* ""))
         (TRANSLATION-INIT)
         (SETQ *CODE-BASE* (SET-CODE-BASE |fn|))
         (AND (NEQ 0 (LOGAND (|fetch| (FNHEADER STARTPC) |of| *CODE-BASE*)
                            1))
              (ERROR "Illegal Start Pc, Cannot Translate " |fn|))
         (SETQ PC-OFFSET (MAKE-PC-OFFSET *CODE-BASE*))
         (SETQ *VAR-OFFSETS* (MAKE-VAR-OFFSETS *CODE-BASE*))
         (SETQ NEW-STKMIN (CODEWALK1 (+ PC-OFFSET GCONST-OFFSET)))
         (|if| (|fetch| (FNHEADER NATIVE) |of| *CODE-BASE*)
             |then| (PRINTOUT *NATIVE-STREAM* "Already Native Code for " |fn| T)
           |else| (LET ((|re-map-list| (FIND-FN0-OBJECTS *SAW-ENVCALL*)))
                           (|if| |re-map-list|
                               |then| |re-map-list|
                             |else| (SETQ OLD-CODE-BASE *CODE-BASE*)
                                   (MAKE-NEW-CODE-BLOCK |fn| PC-OFFSET NEW-STKMIN GCONST-OFFSET)
                                   (SETUP-TRANSLATION-FNS)
                                   (|if| *DEBUG-TRANSLATOR*
                                       |then| (SETQ CODE-BASE *CODE-BASE*)
                                             (SETQ EP *ENTRY-POINTS*))
                                   (CODEWALK2 |fn| |file-name| GCONST-OFFSET (+ PC-OFFSET 
                                                                                    GCONST-OFFSET))
                                   (|if| |make-the-file|
                                       |then| (MAKE-PROGRAM-FILE |file-name| |keep-cr-eol|))
                                   (|if| |set-native|
                                       |then| (LOADNATIVE |fn| |file-name| |file-name| 
                                                         *CODE-BASE* OLD-CODE-BASE)
                                     |else| *CODE-BASE*)))))))
)
(DEFINEQ

(NUT
  (LAMBDA (FN)                                           (* \; "Edited 13-Jun-88 11:49 by rtk")
    (IF (LISTP FN)
        THEN (MAPCAR FN 'NUT)
      ELSE (LET* ((CODE-BASE (SET-CODE-BASE FN))
                      (OLD-CODE-BLOCK (AND CODE-BASE (OR (|fetch| (FNHEADER NATIVE) |of|
                                                                                        CODE-BASE)
                                                         (ERROR FN "not native  code"))
                                           (FETCH-GCONST CODE-BASE 6))))
                     (AND OLD-CODE-BLOCK (SET-NEW-FUNCTION-DEF FN OLD-CODE-BLOCK T))
                     T))))

(FETCH-GCONST
  (LAMBDA (FN-OBJ OFFSET)                                (* \; "Edited 31-May-88 17:46 by rtk")
    (LET* ((BYTE-OFFSET (+ (|fetch| (FNHEADER STARTPC) |of| FN-OBJ)
                           OFFSET))
           (HI-BLOCK (\\GETBASEBYTE FN-OBJ (+ BYTE-OFFSET 1)))
           (LO-BLOCK1 (\\GETBASEBYTE FN-OBJ (+ BYTE-OFFSET 2)))
           (LO-BLOCK2 (\\GETBASEBYTE FN-OBJ (+ BYTE-OFFSET 3)))
           (LO-BLOCK (LOGOR (LLSH LO-BLOCK1 8)
                            LO-BLOCK2)))
          (VAG2 HI-BLOCK LO-BLOCK))))
)
(DEFINEQ

(LINK-C-CODE
  (LAMBDA (LISP-FN-NAME C-CODE-FILE-NAME ENTRY-PT-NAME)  (* \; "Edited 17-Jun-88 18:14 by rtk")
    (LET* ((*NATIVE-STREAM* T)
           (SOURCE-FN-OBJ (SET-CODE-BASE 'LINK-FN-CODE-BLOCK))
           (STARTPC (|fetch| (FNHEADER STARTPC) |of| SOURCE-FN-OBJ))
           (DEST-FN-OBJ (CODE-BLOCK-COPY SOURCE-FN-OBJ STARTPC (+ 8 STARTPC)
                               0
                               (+ STARTPC (MAKE-PC-OFFSET SOURCE-FN-OBJ))
                               *NATIVE-GCONST-OFFSET* NIL LISP-FN-NAME)))
          (LET* ((FULL-FILE-NAME-NO-BRACKETS (CONCAT *NATIVE-TEMP-FILE-DIRECTORY* "/" (FIX-FILENAME
                                                                                       LISP-FN-NAME))
                        )
                 (FILE-SIZE 0)
                 (NATIVE-CODE-BLOCK-PTR 0)
                 (NATIVE-CODE-ADDR 0)
                 (HEX-LOAD-ADDR 0)
                 (LOAD-FILE-SIZE 0)
                 (RET-TO-DISPATCH (OR (AND (EQ (MACHINETYPE)
                                               'MAIKO)
                                           (SUBRCALL NATIVE-MEMORY-REFERENCE 2 0))
                                      0))
                 (NATIVE-CODE-INSERT-BYTES (CONS 72 (CONS 121 (APPEND (UNPACK-NUMBER 
                                                                             RET-TO-DISPATCH 4)
                                                                     (UNPACK-NUMBER 20081 2)
                                                                     (LIST 4 14 15 9)))))
                 (NATIVE-CODE-OFFSET (+ (LENGTH NATIVE-CODE-INSERT-BYTES)
                                        4)))
                (AND (OR (AND (EQ (MACHINETYPE)
                                  'MAIKO)

                              (* |;;| "Execute the Unix C Compiler ")

                              (* |;;| "Get the Object File SIze")

                              (SETQ FILE-SIZE (GET-NATIVE-LOAD-SIZE (CONCAT "{UNIX}" 
                                                                               C-CODE-FILE-NAME)))

                              (* |;;| "Allocate a block big enough to hold the object")

                              (SETQ NATIVE-CODE-BLOCK-PTR (\\ALLOCBLOCK (FOLDHI (+ NATIVE-CODE-OFFSET
                                                                                   FILE-SIZE)
                                                                               BYTESPERCELL)
                                                                 UNBOXEDBLOCK.GCT CELLSPERQUAD 
                                                                 CELLSPERQUAD))
                              (SETQ NATIVE-CODE-ADDR (LISP-ADDR-TO-NATIVE-ADDR 
                                                            NATIVE-CODE-BLOCK-PTR))

                              (* |;;| "Execute the Unix Linker")
                                                             (* DO-EXEC-COMMAND
                                                           (CL:FORMAT NIL 
                                                 "~a/ld -N -s  -e _~a -Ttext ~x -A ~a ~a -o ~a -lc"
                            *NATIVE-BIN-DIRECTORY* (OR ENTRY-PT-NAME LISP-FN-NAME)
                                                           (+ NATIVE-CODE-OFFSET 
                                                           NATIVE-CODE-ADDR) 
                                                           *NATIVE-LISP-RUN-FILENAME* 
                                                           C-CODE-FILE-NAME 
                                                           FULL-FILE-NAME-NO-BRACKETS))
                              (DO-EXEC-COMMAND (CL:FORMAT NIL 
                                                         "~a/ld -N -s   -Ttext ~x -A ~a ~a -o ~a -lc"
                                                          *NATIVE-BIN-DIRECTORY* (+ 
                                                                                   NATIVE-CODE-OFFSET
                                                                                    NATIVE-CODE-ADDR)
                                                          *NATIVE-LISP-RUN-FILENAME* C-CODE-FILE-NAME
                                                          FULL-FILE-NAME-NO-BRACKETS))
                              (PROGN (PRINTOUT *NATIVE-STREAM* "Load " C-CODE-FILE-NAME " At " 
                                            NATIVE-CODE-ADDR " for " FILE-SIZE " bytes." T)
                                     T)

                              (* |;;| "Load the code into lisp space")

                              (SETQ NATIVE-ENTRY-ADDR (LOAD-NATIVE-FILE 
                                                             FULL-FILE-NAME-NO-BRACKETS 
                                                             NATIVE-CODE-BLOCK-PTR 
                                                             NATIVE-CODE-INSERT-BYTES)))

                         (* |;;| "Allocate a dummy block if not maiko")

                         (SETQ NATIVE-CODE-BLOCK-PTR (\\ALLOCBLOCK (FOLDHI *CODE-SIZE* BYTESPERCELL)
                                                            UNBOXEDBLOCK.GCT CELLSPERQUAD 
                                                            CELLSPERQUAD)))

                     (* |;;| "Set Native Adder in Fn Object")

                     (PROGN (PRINTOUT T "set native addr" T)
                            T)
                     (SET-NATIVE-ADDR LISP-FN-NAME DEST-FN-OBJ NATIVE-CODE-BLOCK-PTR 
                            NATIVE-CODE-ADDR NATIVE-ENTRY-ADDR)

                     (* |;;| "Add the New GCONST  xx POP opcodes")

                     (PROGN (PRINTOUT T "ADD-GCONST" T)
                            T)
                     (ADD-GCONST DEST-FN-OBJ 0 NATIVE-CODE-BLOCK-PTR)

                     (* |;;| "Set the New Function Definition")

                     (PROGN (PRINTOUT T "SET-NEW-FUNCTION-DEF" T)
                            T)
                     (SET-NEW-FUNCTION-DEF LISP-FN-NAME DEST-FN-OBJ T)
                     DEST-FN-OBJ)))))

(LINK-FN-CODE-BLOCK
  (LAMBDA (DUMMY)
    NIL))

(UNPACK-NUMBER
  (LAMBDA (NUMBER SIZE)                                  (* \; "Edited  1-Jun-88 11:50 by rtk")
    (|for| I |from| (SUB1 SIZE) |to| 0 |by| -1
       |collect| (LOGAND 255 (LRSH NUMBER (TIMES 8 I))))))
)



(* |;;| "Pass 1 Functions")

(DEFINEQ

(CODEWALK1
  (LAMBDA (PC-OFFSET)                                    (* \; "Edited 21-Jun-88 20:26 by rtk")

(* |;;;| "This Pass  identifies jump targets, sets jump addresses, identifies  following opcodes, and other information used in the 2nd pass. ")

    (DECLARE (SPECIAL *ENTRY-POINTS* *CODE-SIZE* *START-PC* *FN-NAME* *CODE-SIZE* 
                        *NUMBER-OF-ARGS* *PVAR-QUAD-SIZE* *STACK-MIN-SIZE* *CODE-BASE* *GCONST-PTRS*
                        *SAW-ENVCALL* *FN-OBJECT-REMAP-LIST* *DEBUG-TRANSLATOR*))
    (LET (TAG OP# (STACK-DEPTH 0)
              (MAX-PUSH-COUNT 0)
              (START-LEVEL 0)
              (STACK-HEADER-OVERHEAD 6)
              (SAFTEY-SLOTS 16))
         (SETQ *START-PC* (|fetch| (FNHEADER STARTPC) |of| *CODE-BASE*))
         (SETQ *FN-NAME* (|fetch| (FNHEADER FRAMENAME) |of| *CODE-BASE*))
         (SETQ *NUMBER-OF-ARGS* (|fetch| (FNHEADER NA) |of| *CODE-BASE*))
         (SETQ *PVAR-QUAD-SIZE* (|fetch| (FNHEADER PV) |of| *CODE-BASE*))
         (SETQ *STACK-MIN-SIZE* (|fetch| (FNHEADER STKMIN) |of| *CODE-BASE*))
         (SETQ STACK-DEPTH (IPLUS (ITIMES (ADD1 *PVAR-QUAD-SIZE*)
                                         CELLSPERQUAD)
                                  (MAX *NUMBER-OF-ARGS* 0)
                                  STACK-HEADER-OVERHEAD SAFTEY-SLOTS))
         (SETQ START-LEVEL STACK-DEPTH)
         (PRINTOUT *NATIVE-STREAM* "Translation Pass 1: " *FN-NAME* T)
         (PROG ((CODELOC *START-PC*)
                B B1 B2 B3 LEN PC LEVADJ STACK-EFFECT STK NEW-REC LAST-REC)
           LP  (SETQ PC CODELOC)
               (SETQ LEN (LOCAL (|fetch| OPNARGS |of| (SETQ TAG (\\FINDOP (SETQ B
                                                                                   (GETBYTE 
                                                                                          *CODE-BASE*
                                                                                          )))))))
               (SETQ OP# (|fetch| OP# |of| TAG))
               (SETQ LEVADJ (|fetch| LEVADJ |of| TAG))
               (LET ((ELT-CACHE (ELT *ENTRY-POINTS* (IPLUS PC-OFFSET PC))))

                    (* |;;| "Stack Depth is Unknown (there must only be a backward jump to here")

                    (|if| (NULL STACK-DEPTH)
                        |then| (SETQ STACK-DEPTH 0)
                              (SETQ START-LEVEL 0))

                    (* |;;| "There was a forward jump to this location, compare stack depth")

                    (|if| (AND ELT-CACHE)
                        |then|                           (* |if| (AND (NEQ (CAR ELT-CACHE) 
                                                           STACK-DEPTH) (NEQ 0 STACK-DEPTH) 
                                                           *DEBUG-TRANSLATOR*) |then|
                                                           (PRINTOUT T "UnEqual Levels at "
                                                           (IPLUS PC-OFFSET PC) T)
                                                           (PRINTOUT T "Old: " ELT-CACHE 
                                                           ", New: " STACK-DEPTH T))
                              (SETQ STACK-DEPTH (MAX (CAR ELT-CACHE)
                                                     STACK-DEPTH))
                              (SETQ START-LEVEL (MIN (CADDR ELT-CACHE)
                                                     START-LEVEL))
                              (SETQ MAX-PUSH-COUNT (MAX (CADR ELT-CACHE)
                                                        MAX-PUSH-COUNT)))
                    (SETQ MAX-PUSH-COUNT (MAX (- STACK-DEPTH START-LEVEL)
                                              MAX-PUSH-COUNT))

                    (* |;;| "Make the new record")

                    (SETQ NEW-REC
                     (|create| BYTE-INFO-REC
                            PC _ (+ PC PC-OFFSET)
                            OPCODE _ B
                            OPCODE-REC _ TAG
                            LEVEL-ADJUST _ LEVADJ
                            OPLENGTH _ LEN
                            JUMP-TARGET _ ELT-CACHE
                            ENTRY-STACK-DEPTH _ STACK-DEPTH
                            CURRENT-STACK-MAX _ MAX-PUSH-COUNT
                            CURRENT-START-LEVEL _ START-LEVEL
                            ARG1 _ 0
                            ARG2 _ 0
                            ARG3 _ 0)))
               (AND LAST-REC (|replace| (BYTE-INFO-REC NEXT-BYTE-REC) |of| LAST-REC
                                |with| NEW-REC))
               (SETQ LAST-REC NEW-REC)
               (COND
                  ((IGREATERP LEN 0)
                   (SETQ B1 (GETBYTE *CODE-BASE*))
                   (|replace| (BYTE-INFO-REC ARG1) |of| NEW-REC |with| B1)))
               (COND
                  ((IGREATERP LEN 1)
                   (SETQ B2 (GETBYTE *CODE-BASE*))
                   (|replace| (BYTE-INFO-REC ARG2) |of| NEW-REC |with| B2)))
               (COND
                  ((IGREATERP LEN 2)
                   (SETQ B3 (GETBYTE *CODE-BASE*))
                   (|replace| (BYTE-INFO-REC ARG3) |of| NEW-REC |with| B3)))
               (|replace| (BYTE-INFO-REC OP-NAME) |of| NEW-REC
                  |with| (OR (|fetch| OPCODENAME |of| TAG)
                                 (|fetch| OPPRINT |of| TAG)))
               (SETQ STACK-EFFECT (COND
                                     ((NUMBERP LEVADJ)
                                      LEVADJ)
                                     ((FMEMB LEVADJ '(NCJUMP CJUMP))
                                      -1)
                                     ((EQ 'JUMP LEVADJ)
                                      0)
                                     ((EQ 'FNX LEVADJ)
                                      (MINUS (SUB1 B1)))
                                     ((LISTP LEVADJ)
                                      (COND
                                         ((EQ 'POP.N LEVADJ)
                                          (MINUS B1))
                                         ((EQ 'UNWIND LEVADJ)
                                          0)
                                         ((EQ 'JUMP LEVADJ)
                                          0)
                                         ((FMEMB (|fetch| OPCODENAME |of| TAG)
                                                 '(UBFLOAT1 UBFLOAT2 UBFLOAT3))
                                          (CAR LEVADJ))
                                         ((FMEMB (|fetch| OPCODENAME |of| TAG)
                                                 '(DOVEMISC))
                                          (NTH LEVADJ B1))
                                         (T 0)))
                                     (T 0)))
               (|replace| (BYTE-INFO-REC STACK-EFFECT) |of| NEW-REC |with| STACK-EFFECT)
               (SETA *ENTRY-POINTS* (+ PC PC-OFFSET)
                     NEW-REC)
               (COND
                  ((LISTP OP#)
                   (SETQ OP# (CAR OP#))))
               (SELECTQ (OR (AND (NEQ T (|fetch| OPPRINT |of| TAG))
                                 (|fetch| OPPRINT |of| TAG))
                            (|fetch| OPCODENAME |of| TAG))
                   (-X- (SETQ *CODE-SIZE* (IPLUS CODELOC 5)) (* |if| *DEBUG-TRANSLATOR* |then|
                                                           (PRINTOUT T "My stack min: "
                                                           (TIMES 2 MAX-PUSH-COUNT) " Given: "
                                                           (|fetch| (FNHEADER STKMIN) |of| 
                                                           *CODE-BASE*) T))
                        (RETURN (MAX (TIMES 2 MAX-PUSH-COUNT)
                                     (|fetch| (FNHEADER STKMIN) |of| *CODE-BASE*))))
                   (GCONST (LET* ((|const-ptr| (VAG2 B1 (LOGOR (LLSH B2 8)
                                                               B3)))
                                  (|remap-info| (FASSOC |const-ptr| *FN-OBJECT-REMAP-LIST*))
                                  (|remap-datum| (AND |remap-info| (CDR |remap-info|))))
                                 (|if| |remap-datum|
                                     |then| (|push| *GCONST-PTRS* (LIST |remap-datum|
                                                                                (+ PC PC-OFFSET)
                                                                                |const-ptr|))
                                   |else| (|push| *GCONST-PTRS* (LIST |const-ptr|
                                                                              (+ PC PC-OFFSET)
                                                                              NIL)))))
                   (JUMP (|if| (SETJUMPTARGET (IPLUS (IDIFFERENCE B OP#)
                                                             2)
                                          CODELOC NEW-REC STACK-EFFECT PC-OFFSET)
                             |then| (SETQ STACK-DEPTH NIL)))
                   (JUMPX (|if| (SETJUMPTARGET (COND
                                                          ((IGEQ B1 128)
                                                           (IDIFFERENCE B1 256))
                                                          (T B1))
                                           CODELOC NEW-REC (|if| (EQ (|fetch| LEVADJ
                                                                            |of| TAG)
                                                                         'NCJUMP)
                                                               |then| 0
                                                             |else| STACK-EFFECT)
                                           PC-OFFSET)
                              |then| (SETQ STACK-DEPTH NIL)))
                   (JUMPXX (|if| (SETJUMPTARGET (IPLUS (LLSH B1 8)
                                                               B2
                                                               (COND
                                                                  ((IGREATERP B1 127)
                                                                   -65536)
                                                                  (T 0)))
                                            CODELOC NEW-REC STACK-EFFECT PC-OFFSET)
                               |then| (SETQ STACK-DEPTH NIL)))
                   (RETURN (SETQ STACK-DEPTH NIL))
                   (\\RETURN (SETQ STACK-DEPTH NIL))
                   (ENVCALL (|push| *SAW-ENVCALL* NEW-REC))
                   NIL)
               (SETQ STACK-DEPTH (+ STACK-DEPTH (COND
                                                   ((OR (EQ LEVADJ 'JUMP)
                                                        (AND (LISTP LEVADJ)
                                                             (EQ (CAR LEVADJ)
                                                                 'JUMP)))
                                                    (SETQ STACK-DEPTH NIL)
                                                    (GO LP))
                                                   (T STACK-EFFECT))))
               (|if| (EQ 0 (LOGAND 15 PC))
                   |then| (BLOCK))
               (GO LP)))))

(SETJUMPTARGET
  (LAMBDA (N CODELOC BYTE-REC THIS-STACK-EFFECT PC-OFFSET)
                                                             (* \; "Edited  6-Jun-88 15:18 by rtk")
    (LET* ((TARGET (+ N (IDIFFERENCE CODELOC (ADD1 (|fetch| (BYTE-INFO-REC OPLENGTH) |of|
                                                                                         BYTE-REC)))
                      PC-OFFSET))
           (JUMP-TARGET-INFO (ELT *ENTRY-POINTS* TARGET))
           (JUMP-EXIT-STACK-DEPTH (IPLUS (|fetch| (BYTE-INFO-REC ENTRY-STACK-DEPTH) |of|
                                                                                        BYTE-REC)
                                         THIS-STACK-EFFECT))
           (FORWARD-JUMP (GREATERP TARGET (+ CODELOC PC-OFFSET)))
           (TARGET-ENTRY-STACK-DEPTH (AND JUMP-TARGET-INFO (OR (AND (NOT FORWARD-JUMP)
                                                                    (|fetch| (BYTE-INFO-REC
                                                                                  ENTRY-STACK-DEPTH)
                                                                       |of| JUMP-TARGET-INFO))
                                                               (AND FORWARD-JUMP (CAR 
                                                                                     JUMP-TARGET-INFO
                                                                                      ))))))
          (|replace| (BYTE-INFO-REC JUMP-TO-ADDRESS) |of| BYTE-REC |with| TARGET)
          (COND
             (FORWARD-JUMP 

                    (* |;;| "Forward JUMP (which has already been referenced)")

                    (DESTRUCTURING-BIND (TARGET-ENTRY-DEPTH TARGET-MAX-DEPTH TARGET-START-LEVEL)
                           (OR JUMP-TARGET-INFO (LIST JUMP-EXIT-STACK-DEPTH (|fetch| (
                                                                                        BYTE-INFO-REC
                                                                                          
                                                                                    CURRENT-STACK-MAX
                                                                                          )
                                                                               |of| BYTE-REC)
                                                      (|fetch| (BYTE-INFO-REC CURRENT-START-LEVEL
                                                                          ) |of| BYTE-REC)))
                                                             (* |if| (NEQ TARGET-ENTRY-DEPTH 
                                                           JUMP-EXIT-STACK-DEPTH) |then|
                                                           (PRINTOUT T 
                                                           "UnEqual Stack Depth Jump from: "
                                                           (|fetch| (BYTE-INFO-REC PC) |of| 
                                                           BYTE-REC) T) (PRINTOUT T "JUMP: "
                                                           (|fetch| (BYTE-INFO-REC OPCODE-REC) 
                                                           |of| BYTE-REC) T) (PRINTOUT T 
                                                           "Target JUMP level: " 
                                                           JUMP-TARGET-INFO T))
                           (SETA *ENTRY-POINTS* TARGET (LIST (MAX TARGET-ENTRY-DEPTH 
                                                                  JUMP-EXIT-STACK-DEPTH)
                                                             (MAX TARGET-MAX-DEPTH
                                                                  (|fetch| (BYTE-INFO-REC 
                                                                                    CURRENT-STACK-MAX
                                                                                      ) |of|
                                                                                        BYTE-REC))
                                                             (MIN TARGET-START-LEVEL
                                                                  (|fetch| (BYTE-INFO-REC 
                                                                                  CURRENT-START-LEVEL
                                                                                      ) |of|
                                                                                        BYTE-REC)))))
                    )
             (T 
                (* |;;| "A backwards JUMP")

                (|replace| (BYTE-INFO-REC JUMP-TARGET) |of| JUMP-TARGET-INFO |with|
                                                                                     T)
                (|replace| (BYTE-INFO-REC NEGATIVE-JUMP-TARGET) |of| JUMP-TARGET-INFO
                   |with| T)                             (* |if| (NEQ JUMP-EXIT-STACK-DEPTH 
                                                           TARGET-ENTRY-STACK-DEPTH) |then|
                                                           (PRINTOUT T 
                                                           "UnEqual Stack Depth, jump from: "
                                                           (|fetch| (BYTE-INFO-REC PC) |of| 
                                                           BYTE-REC) T) (PRINTOUT T "JUMP[" 
                                                           JUMP-EXIT-STACK-DEPTH "]: "
                                                           (|fetch| (BYTE-INFO-REC OPCODE-REC) 
                                                           |of| BYTE-REC) T) (PRINTOUT T "TO[" 
                                                           TARGET-ENTRY-STACK-DEPTH "]: "
                                                           (|fetch| (BYTE-INFO-REC OPCODE-REC) 
                                                           |of| JUMP-TARGET-INFO) T))
                ))
          (SELECTQ (|fetch| (BYTE-INFO-REC LEVEL-ADJUST) |of| BYTE-REC)
              (NCJUMP NIL)
              (CJUMP NIL)
              T))))
)

(DEFMACRO GETBYTE (BASE)
   `(\\GETBASEBYTE ,BASE (PROG1 CODELOC (|add| CODELOC 1))))



(* |;;| "Pass 2 Functions ")

(DEFINEQ

(CODEWALK2
  (LAMBDA (FN ENTRY-NAME GCONST-OFFSET PC-ADJUST-SIZE)   (* \; "Edited 21-Jun-88 20:26 by rtk")

(* |;;;| "2nd pass which generates the code from the ENTRY-POINTS array generated in pass1")

    (DECLARE (SPECIAL *ENTRY-POINTS* *CODE-SIZE* *START-PC* *CPROGRAM* *INLINES* *EVAL-STACK* 
                        *ERROR-STACK* *ERROR-CASES* *TRANSLATION-TABLE* *TARGET-MACHINE.N* 
                        *TARGET-MACHINE*))
    (PRINTOUT *NATIVE-STREAM* "Translation Pass 2: " FN T)
    (SETQ *CPROGRAM* NIL)
    (SETQ *INLINES* NIL)
    (SETQ *EVAL-STACK* NIL)
    (SETQ *ERROR-CASES* NIL)
    (SETQ *ERROR-STACK* NIL)
    (ADD-FN-HEADER-INFO FN ENTRY-NAME)
    (LET
     ((*PREV-UFN* T)
      *IGNORE-JUMP* *IGNORE-THIS-JUMP*)
     (DECLARE (SPECVAR *PREV-UFN* *IGNORE-JUMP* *IGNORE-THIS-JUMP*))
     (|bind| (\i _ (+ *START-PC* GCONST-OFFSET)) |while| (GEQ *CODE-SIZE* \i)
        |do|
        (SETQ *IGNORE-THIS-JUMP* *IGNORE-JUMP*)
        (SETQ *IGNORE-JUMP* NIL)
        (SETQ *ERROR-STACK* NIL)
        (LET*
         ((*ARG-COUNT* 0)
          (*INFO-REC* NIL)
          (*ERROR-PC* NIL)
          (*INLINE-ERROR-STACK* NIL)
          (*PC-BUMP-SIZE* 1)
          (BYTE-REC (ELT *ENTRY-POINTS* \i))
          (OPCODE (|fetch| (BYTE-INFO-REC OPCODE) |of| BYTE-REC))
          (TRANS-REC (ELT *TRANSLATION-TABLE* OPCODE)))
         (DECLARE (SPECVARS *PC-BUMP-SIZE* *ARG-COUNT* *ERROR-PC* *INLINE-ERROR-STACK* *INFO-REC*
                             ))
         (|if| (ZEROP OPCODE)
             |then| (ADD-LINE (CONCAT "/* exit " ENTRY-NAME " */ } "))
                   (RETURN))
         (ADD-CASE (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC)
                *PREV-UFN*
                (|fetch| (BYTE-INFO-REC JUMP-TARGET) |of| BYTE-REC)
                (|fetch| (BYTE-INFO-REC NEGATIVE-JUMP-TARGET) |of| BYTE-REC)
                (|fetch| (TRANSLATION-REC MAY-UFN) |of| TRANS-REC))
         (|if| TRANS-REC
             |then| (LET* ((|inline-expansions| (|fetch| (TRANSLATION-REC INLINE-EXPANSIONS)
                                                       |of| TRANS-REC))
                               |expansion|
                               (|parsed-line|
                                (COND
                                   ((AND |inline-expansions|
                                         (SETQ |expansion|
                                          (OR (AND (CL:MULTIPLE-VALUE-BIND (MDATA MINFO)
                                                          (OPERAND-GET)
                                                          (EQ 'SMALL-CONST (|fetch| (INFO-REC
                                                                                         INFO-TYPE)
                                                                              |of| MINFO)))
                                                   (LISTGET |inline-expansions| *TARGET-MACHINE.N*))
                                              (LISTGET |inline-expansions| *TARGET-MACHINE*))))
                                    (INLINE-EXPAND TRANS-REC BYTE-REC |expansion|))
                                   (T (APPLY* (|fetch| (TRANSLATION-REC PARSE-FN) |of| 
                                                                                            TRANS-REC
                                                     )
                                             TRANS-REC BYTE-REC FN NIL PC-ADJUST-SIZE NIL)))))
                              (|if| |parsed-line|
                                  |then| (CONDITIONAL-PARSER TRANS-REC BYTE-REC FN 
                                                    |parsed-line|)
                                        (ADD-ERROR-ENTRY TRANS-REC BYTE-REC)))
                   (SETQ *PREV-UFN* (|fetch| (TRANSLATION-REC MAY-UFN) |of| TRANS-REC))
           |else| (CONDITIONAL-PARSER TRANS-REC BYTE-REC FN (BCE-PARSER \i BYTE-REC))
                 (SETQ *PREV-UFN* T))
         (SETQ \i (IPLUS \i (|fetch| (BYTE-INFO-REC OPLENGTH) |of| BYTE-REC)
                         *PC-BUMP-SIZE*))
         (|if| (EQ 0 (LOGAND 15 \i))
             |then| (BLOCK)))))))

(CONDITIONAL-PARSER
  (LAMBDA (TRANS-REC BYTE-REC FN-NAME |operand-string|)  (* \; "Edited 21-Jun-88 22:42 by rtk")
    (DECLARE (SPECIAL *IGNORE-JUMP* *INFO-REC*))

    (* |;;| "See if Next OPCODE is a Jump.  ")

    (* |;;| "IF so we can combine the condition & the Jump to avoid the Push & Pop")

    (LET* ((|next-rec| (|fetch| (BYTE-INFO-REC NEXT-BYTE-REC) |of| BYTE-REC))
           (|next-opcode-rec| (|fetch| (BYTE-INFO-REC OPCODE-REC) |of| |next-rec|))
           (|next-next-rec| (|fetch| (BYTE-INFO-REC NEXT-BYTE-REC) |of| |next-rec|)))
          (COND
             ((AND (EQ (|fetch| (BYTE-INFO-REC LEVEL-ADJUST) |of| |next-rec|)
                       'CJUMP)
                   (|fetch| (TRANSLATION-REC PUSHING-RESULT) |of| TRANS-REC)
                   (NOT (|fetch| (BYTE-INFO-REC JUMP-TARGET) |of| |next-rec|)))
              (PUSH-ALL-OPERANDS)
              (IF (TYPEP |operand-string| 'LINE-INFO-REC)
                  THEN (ADD-OPERAND-LINE (|if| (FMEMB (|fetch| OPCODENAME
                                                                     |of| |next-opcode-rec|)
                                                                  '(TJUMP TJUMPX))
                                                     |then| "	if (("
                                                   |else| "	if (!(")
                                  |operand-string|
                                  (CONCAT ")) {goto pc" (|fetch| (BYTE-INFO-REC JUMP-TO-ADDRESS)
                                                           |of| |next-rec|)
                                         "; }"))
                ELSE (ADD-OPERAND-LINE (|if| (FMEMB (|fetch| OPCODENAME |of|
                                                                                        
                                                                                    |next-opcode-rec|
                                                                       )
                                                                '(TJUMP TJUMPX))
                                                   |then| "	if (("
                                                 |else| "	if (!(")
                                NIL
                                (CONCAT |operand-string| ")) {goto pc" (|fetch| (BYTE-INFO-REC
                                                                                     JUMP-TO-ADDRESS)
                                                                          |of| |next-rec|)
                                       "; }")))
              (|if| (|fetch| (TRANSLATION-REC MAY-UFN) |of| TRANS-REC)
                  |then| (ADD-LINE (CONCAT "goto pc" (|fetch| (BYTE-INFO-REC PC)
                                                                |of| |next-next-rec|)
                                                  ";")
                                    T)
                |else| (SETQ *IGNORE-JUMP* T))
              (|replace| (BYTE-INFO-REC JUMP-TARGET) |of| |next-next-rec| |with| T))
             (T (|if| (|fetch| (TRANSLATION-REC DEFER-PUSH) |of| TRANS-REC)
                    |then| (OPERAND-PUSH |operand-string| *INFO-REC*)
                  |else| (|if| (OR (|fetch| (TRANSLATION-REC MAY-UFN) |of| TRANS-REC)
                                           (|fetch| (TRANSLATION-REC PUSHING-RESULT) |of|
                                                                                         TRANS-REC))
                                 |then| (PUSH-ALL-OPERANDS))
                        (|if| (|fetch| (TRANSLATION-REC PUSHING-RESULT) |of| TRANS-REC)
                            |then| (SETQ *ERROR-STACK* (ADD-PUSH-OPERAND-LINE 
                                                                  |operand-string| *ERROR-STACK* 
                                                                  *INFO-REC*))
                          |else| (ADD-OPERAND-LINE "	" |operand-string| ";"))))))))

(INLINE-EXPAND
  (LAMBDA (TRANS-REC BYTE-REC EXPANSION-LIST)            (* \; "Edited 21-Jun-88 23:44 by rtk")
    (DECLARE (SPECIAL *ERROR-STACK* *ERROR-PC* *INLINE-ERROR-STACK* *REPLACEMENT-STRING*))
    (LET*
     ((*TOS-INFO* NIL)
      (*TOS-VAL* NIL)
      (|pc| (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC))
      (|may-ufn| (|fetch| (TRANSLATION-REC MAY-UFN) |of| TRANS-REC))
      (|inline-name| (CONCAT "_" (CAAAR EXPANSION-LIST)
                            |pc|))
      (|error-pc| (CONCAT "errorpc" |pc|))
      (|argcount| 0)
      (\n (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC))
      (|new-lines| NIL)
      (TOS-CALL-VALUE NIL)
      (TOS-1-CALL-VALUE NIL)
      (ERROR-RETRY-STRING (|fetch| (TRANSLATION-REC TRANS-PATTERN) |of| TRANS-REC))
      (ERROR-RETRY-PARMS (|fetch| (TRANSLATION-REC TRANS-PARAMATERS) |of| TRANS-REC))
      (NEW-LINE-INFO-REC (|create| LINE-INFO-REC))
      (INLINE-LINES NIL)
      (PATTERN-LIST NIL)
      (CALL-ACTUALS NIL))
     (DECLARE (SPECVARS *TOS-INFO* *TOS-VAL*))

     (* |;;| "substitute the inline info first ")

     (SETQ INLINE-LINES (|for| INLINE-PARMS |in| (CDR EXPANSION-LIST)
                           |collect| (LET ((INLINE-LINE-INFO (|create| LINE-INFO-REC)))
                                              (|replace| (LINE-INFO-REC PATTERN-LIST)
                                                 |of| INLINE-LINE-INFO |with| (CAR 
                                                                                         INLINE-PARMS
                                                                                           ))
                                              (|replace| (LINE-INFO-REC PARAMETER-LIST)
                                                 |of| INLINE-LINE-INFO |with| (CADR 
                                                                                         INLINE-PARMS
                                                                                            ))
                                              (|replace| (LINE-INFO-REC ACTUAL-PARAMETERS)
                                                 |of| INLINE-LINE-INFO
                                                 |with| (|for| PARM |in| (CADR 
                                                                                         INLINE-PARMS
                                                                                           )
                                                               |collect| (PARM-SUBSTITUTE
                                                                              PARM TRANS-REC BYTE-REC
                                                                              NIL NIL)))
                                              INLINE-LINE-INFO)))

     (* |;;| "substitute the call line parameters")

     (SETQ PATTERN-LIST (CAAR EXPANSION-LIST))
     (SETQ CALL-ACTUALS (|for| PARM |in| (CADAR EXPANSION-LIST)
                           |collect| (PARM-SUBSTITUTE PARM TRANS-REC BYTE-REC NIL NIL)))
     (|replace| (LINE-INFO-REC ACTUAL-PARAMETERS) |of| NEW-LINE-INFO-REC |with| 
                                                                                       CALL-ACTUALS)
     (|replace| (LINE-INFO-REC PATTERN-LIST) |of| NEW-LINE-INFO-REC |with| PATTERN-LIST)
     (|replace| (LINE-INFO-REC PARAMETER-LIST) |of| NEW-LINE-INFO-REC |with| (CADAR
                                                                                          
                                                                                       EXPANSION-LIST
                                                                                          ))
     (|for| PAT |in| (CADAR EXPANSION-LIST) |as| ACTUAL |in| CALL-ACTUALS
        |do| (OR (AND (EQ 'POP (CAR PAT))
                          (SETQ |argcount| (PLUS |argcount| 4))
                          (SETQ TOS-CALL-VALUE ACTUAL))
                     (AND (EQ 'POP-1 (CAR PAT))
                          (SETQ |argcount| (PLUS |argcount| 4))
                          (SETQ TOS-1-CALL-VALUE ACTUAL))))

     (* |;;| "Generate the INLINES, replacing other data")

     (ADD-INLINE-LINE (CONCAT ".inline " |inline-name| ", " |argcount|)
            NIL "")
     (|for| LINE |in| INLINE-LINES |do| (ADD-INLINE-LINE "	" LINE ""))
     (ADD-INLINE-LINE ".end " NIL "")
     (SETQ *ARG-COUNT* 0)
     (|if| (NEQ (STRPOS "BCE" (OR (AND (STRINGP ERROR-RETRY-STRING)
                                           ERROR-RETRY-STRING)
                                      (CAR ERROR-RETRY-STRING)))
                    1)
         |then|

         (* |;;| "Make the Error Entry to try the Out of Line Routine.")

         (LET* ((SAVE-ERROR-STACK *ERROR-STACK*)
                (TOS-IS-DEFERRED (NEQ TOS-CALL-VALUE 'POP))
                (TOS-1-IS-DEFERRED (NEQ TOS-1-CALL-VALUE 'POP))
                (ERROR-LINE-INFO-REC (|create| LINE-INFO-REC)))
               (SETQ PATTERN-LIST ERROR-RETRY-STRING)
               (SETQ *ERROR-STACK* NIL)
               (|replace| (LINE-INFO-REC ACTUAL-PARAMETERS) |of| ERROR-LINE-INFO-REC
                  |with|
                  (|for| PARM |in| ERROR-RETRY-PARMS
                     |collect| (PARM-SUBSTITUTE
                                    PARM TRANS-REC BYTE-REC NIL NIL
                                    (SELECTQ (CAR PARM)
                                        (POP (OR (AND TOS-IS-DEFERRED (OR TOS-CALL-VALUE
                                                                          (GET-VAL *TOS-VAL* 
                                                                                 *TOS-INFO*)))
                                                 (OR (AND (EQ TOS-1-CALL-VALUE 'POP)
                                                          'GET_POPPED_2)
                                                     'GET_POPPED)))
                                        (POP-1 (OR (AND TOS-IS-DEFERRED (OR (AND TOS-1-IS-DEFERRED 
                                                                                 TOS-1-CALL-VALUE)
                                                                            'GET_POPPED))
                                                   'GET_POPPED))
                                        (ERRORPC (CONCAT |error-pc| "_b"))
                                        NIL))))
               (|replace| (LINE-INFO-REC PARAMETER-LIST) |of| ERROR-LINE-INFO-REC
                  |with| ERROR-RETRY-PARMS)
               (|replace| (LINE-INFO-REC PATTERN-LIST) |of| ERROR-LINE-INFO-REC |with|
                                                                                        PATTERN-LIST)
               (SETQ *ERROR-STACK* SAVE-ERROR-STACK)
               (SETQ *INLINE-ERROR-STACK* (LIST (CONS 'PUSH ERROR-LINE-INFO-REC)
                                                (CONCAT "goto case" (PLUS |pc| 1 (|fetch|
                                                                                  (BYTE-INFO-REC
                                                                                   OPLENGTH)
                                                                                    |of| BYTE-REC
                                                                                  ))
                                                       "_label;")))))
     NEW-LINE-INFO-REC)))
)



(* |;;| "Parsing Functions")

(DEFINEQ

(BCE-PARSER
  (LAMBDA (TRANS-REC BYTE-REC FN-NAME |optional-string|) (* \; "Edited 17-Jun-88 13:04 by rtk")
    (DECLARE (SPECIAL *CODE-BASE*))
    (PUSH-ALL-OPERANDS)
    (CONCAT "BCE(" (BCE-PC (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC)
                          *CODE-BASE*)
           ", "
           (|fetch| (BYTE-INFO-REC OPCODE) |of| BYTE-REC)
           ")")))

(STR-PARSER
  (LAMBDA (TRANS-REC BYTE-REC FN-NAME WAS-OPTIONAL-STRING)
                                                             (* \; "Edited 22-Jun-88 01:08 by rtk")
    (DECLARE (SPECIAL *EVAL-STACK* *CODE-BASE*))
    (LET ((PATTERN-LIST (|fetch| (TRANSLATION-REC TRANS-PATTERN) |of| TRANS-REC))
          (PARAMATERS (|fetch| (TRANSLATION-REC TRANS-PARAMATERS) |of| TRANS-REC))
          (NEW-LINE-INFO-REC (|create| LINE-INFO-REC))
          (*ADD-HEAD* NIL)
          (*ADD-TAIL* NIL))
         (DECLARE (SPECVARS *ADD-HEAD* *ADD-TAIL*))
         (|replace| (LINE-INFO-REC PARAMETER-LIST) |of| NEW-LINE-INFO-REC |with| 
                                                                                        PARAMATERS)
         (|replace| (LINE-INFO-REC ACTUAL-PARAMETERS) |of| NEW-LINE-INFO-REC
            |with| (|for| PARM |in| PARAMATERS
                          |collect| (PARM-SUBSTITUTE PARM TRANS-REC BYTE-REC NIL NIL)))
         (IF *ADD-HEAD*
             THEN (SETQ PATTERN-LIST (CONS *ADD-HEAD* PATTERN-LIST)))
         (IF *ADD-TAIL*
             THEN (SETQ PATTERN-LIST (APPEND PATTERN-LIST (LIST *ADD-TAIL*))))
         (|replace| (LINE-INFO-REC PATTERN-LIST) |of| NEW-LINE-INFO-REC |with| 
                                                                                      PATTERN-LIST)
         NEW-LINE-INFO-REC)))

(COND-PARSER
  (LAMBDA (TRANS-REC BYTE-REC FN-NAME WAS-OPTIONAL-STRING)
                                                             (* \; "Edited 22-Jun-88 17:41 by rtk")
    (DECLARE (SPECIAL *EVAL-STACK* *CODE-BASE*))
    (LET ((PATTERN-LIST (|fetch| (TRANSLATION-REC TRANS-PATTERN) |of| TRANS-REC))
          (PARAMATERS (|fetch| (TRANSLATION-REC TRANS-PARAMATERS) |of| TRANS-REC))
          (NEW-LINE-INFO-REC (|create| LINE-INFO-REC))
          (*ADD-HEAD* NIL)
          (*ADD-TAIL* NIL))
         (DECLARE (SPECVARS *ADD-HEAD* *ADD-TAIL*))
         (|replace| (LINE-INFO-REC PARAMETER-LIST) |of| NEW-LINE-INFO-REC |with| 
                                                                                        PARAMATERS)
         (|replace| (LINE-INFO-REC ACTUAL-PARAMETERS) |of| NEW-LINE-INFO-REC
            |with| (|for| PARM |in| PARAMATERS
                          |collect| (PARM-SUBSTITUTE PARM TRANS-REC BYTE-REC NIL NIL)))
         (|replace| (LINE-INFO-REC PATTERN-LIST) |of| NEW-LINE-INFO-REC |with| 
                                                                                      PATTERN-LIST)
         (|if| *ADD-HEAD*
             |then| 

                   (* |;;| "It is NOT followed by a jump, so add the IF... stuff appropriate thing")

                   (ADD-OPERAND-LINE *ADD-HEAD* NEW-LINE-INFO-REC *ADD-TAIL*)
                   NIL
           |else| 

                 (* |;;| "Followed by a JUMP so return the deffered value")

                 NEW-LINE-INFO-REC))))

(CONST-PARSER
  (LAMBDA (TRANS-REC BYTE-REC)                           (* \; "Edited 21-Jun-88 18:59 by rtk")
    (PROG1 (STR-PARSER TRANS-REC BYTE-REC)
        (SET-INFO 'INFO-TYPE 'SMALL-CONST))))

(COPY-PARSER
  (LAMBDA (TRANS-REC BYTE-REC FN-NAME |optional-string|) (* \; "Edited 21-Jun-88 11:53 by rtk")
    (DECLARE (SPECIAL *EVAL-STACK* *CODE-BASE* *INFO-REC*))
    (LET ((|c-string| (OR |optional-string| (|fetch| (TRANSLATION-REC PATTERN) |of| TRANS-REC
                                                   ))))

         (* |;;| "Check if the operand should be pushed ")

         (|if| *EVAL-STACK*
             |then| (TOS-CHECK TRANS-REC BYTE-REC ""))

         (* |;;| "Is the Operand still Delayed?")

         (|if| *EVAL-STACK*
             |then| (CL:MULTIPLE-VALUE-BIND (|eval-string| |info-rec|)
                               (OPERAND-GET T)
                               (SETQ *INFO-REC* |info-rec|)
                               (SETQ |c-string| |eval-string|))
           ELSE (STR-PARSER TRANS-REC BYTE-REC FN-NAME |optional-string|)))))

(JUMP-PARSER
  (LAMBDA (TRANS-REC BYTE-REC)                           (* \; "Edited 21-Jun-88 12:03 by rtk")
    (DECLARE (SPECIALS *IGNORE-THIS-JUMP*))
    (|if| *IGNORE-THIS-JUMP*
        |then| NIL
      |else| (STR-PARSER TRANS-REC BYTE-REC))))

(FN-CALL-PARSER
  (LAMBDA (TRANS-REC BYTE-REC FN-NAME OPTIONAL-STRING PC-OFFSET NUM-ARGS)
                                                             (* \; "Edited 23-Jun-88 19:35 by rtk")

    (* |;;| "NUM-ARGS is set by FNX call")

    (DECLARE (SPECIAL *CODE-BASE* *OLD-CODE-BASE*))
    (LET* ((REAL-ARGS (OR NUM-ARGS (|fetch| (TRANSLATION-REC STACK-ARGS) |of| TRANS-REC)))
           (ALLOWED-ARGS (MIN 5 REAL-ARGS))
           (WHO-CALLED (OR (AND NUM-ARGS (|fetch| (BYTE-INFO-REC ARG2) |of| BYTE-REC)
                                (|fetch| (BYTE-INFO-REC ARG3) |of| BYTE-REC)
                                (LOGOR (LLSH (|fetch| (BYTE-INFO-REC ARG2) |of| BYTE-REC)
                                             8)
                                       (|fetch| (BYTE-INFO-REC ARG3) |of| BYTE-REC)))
                           (AND (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)
                                (|fetch| (BYTE-INFO-REC ARG2) |of| BYTE-REC)
                                (LOGOR (LLSH (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)
                                             8)
                                       (|fetch| (BYTE-INFO-REC ARG2) |of| BYTE-REC)))))
           (FN-DEF-CELL (\\DEFCELL (\\VAG2 0 WHO-CALLED)))
           (FN-DEF-CELL-68K (LISP-ADDR-TO-NATIVE-ADDR FN-DEF-CELL))
           (*CALL-SELF* (AND (LITATOM FN-NAME)
                             (EQ (\\LOLOC FN-NAME)
                                 WHO-CALLED)))
           (NEW-PC (PLUS (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC)
                         (OR (AND NUM-ARGS 4)
                             3)))
           (*FN-CALL-STR* (OR (AND *CALL-SELF* (CONCAT NEW-PC ", pc_" ALLOWED-ARGS))
                              (CONCAT (BCE-PC (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC)
                                             *CODE-BASE*)
                                     ", " NEW-PC ", " WHO-CALLED ", " FN-DEF-CELL-68K ", ret_to_fn"
                                     (|if| (GEQ 4 REAL-ARGS)
                                         |then| REAL-ARGS
                                       |else| "x")))))
          (DECLARE (SPECVARS *CALL-SELF* *FN-CALL-STR*))

          (* |;;| "Must push all for function call & return")

          (PUSH-ALL-OPERANDS)
          (ADD-OPERAND-LINE "	" (STR-PARSER TRANS-REC BYTE-REC FN-NAME OPTIONAL-STRING 
                                           PC-OFFSET NUM-ARGS)
                 ";")
          NIL)))

(FN-CALL-PARSERX
  (LAMBDA (TRANS-REC BYTE-REC FN-NAME OPTIONAL-STRING)   (* \; "Edited 14-Jun-88 11:24 by rtk")
    (FN-CALL-PARSER TRANS-REC BYTE-REC FN-NAME OPTIONAL-STRING NIL (|fetch| (BYTE-INFO-REC
                                                                                     ARG1)
                                                                          |of| BYTE-REC))))

(ENVCALL-PARSER
  (LAMBDA (TRANS-REC BYTE-REC FN-NAME OPTIONAL-STRING NUM-ARGS)
                                                             (* \; "Edited 22-Jun-88 16:05 by rtk")
    (DECLARE (SPECVARS *EVAL-STACK* *CODE-BASE*))
    (LET* ((FUNCTION-PTR (LISTGET (|fetch| (BYTE-INFO-REC OPCODE-PROPS) |of| BYTE-REC)
                                'CODE-CONST))
           (NUM-OF-ARGS (LISTGET (|fetch| (BYTE-INFO-REC OPCODE-PROPS) |of| BYTE-REC)
                               'ARG-CONST))
           (BCE-PC-VALUE (BCE-PC (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC)
                                *CODE-BASE*))
           (RETURN-PC (ADD1 (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC))))
          (|if| FUNCTION-PTR
              |then| (ADD-OPERAND-LINE "	" NIL (CONCAT "envcall_native(" RETURN-PC ", "
                                                              (OR NUM-OF-ARGS "POP")
                                                              ", "
                                                              (LISP-ADDR-TO-NATIVE-ADDR 
                                                                     FUNCTION-PTR)
                                                              ", "
                                                              (ITIMES (NATIVE-ADDR-WORD-OFFSET
                                                                       FUNCTION-PTR)
                                                                     2)
                                                              ", "
                                                              (OR (OPERAND-POP)
                                                                  "POP")
                                                              ")"))
                    (PUSH-ALL-OPERANDS)
            |else| (PUSH-ALL-OPERANDS)
                  (ADD-OPERAND-LINE "	" (STR-PARSER TRANS-REC BYTE-REC)
                         ";")
                  (STR-PARSER TRANS-REC BYTE-REC)))
    NIL))

(RETURN-PARSER
  (LAMBDA (TRANS-REC BYTE-REC)                           (* \; "Edited 20-Jun-88 20:16 by rtk")
    (DECLARE (SPECVARS *CODE-BASE* *EVAL-STACK*))

    (* |;;| "Must push all for function call & return")
                                                             (* IGNORE FOR NOW |if| |tos-operand| 
                                                           |then| (* |;;| 
                                               "If TOS is not IVAR[0], then Set IVAR[0]  to result")
                                                           (|if| (OR (NOT (STRINGP 
                                                           |tos-operand|)) (NOT
                                                           (STRING-EQUAL |tos-operand| "IVAR[0]")))
  |then| (SETQ |c-string| (CONCAT "IVAR[0] = " (OPERAND-POP) "; " |c-string|))) |else|
                                                           (* |;;| "Result is whatever is at TOS")
                                                           (SETQ PREFIX-STR "IVAR[0] = POP; "))
    (LET ((PREFIX-STR "IVAR[0] = POP; ")
          (PATTERN-LIST (|fetch| (TRANSLATION-REC TRANS-PATTERN) |of| TRANS-REC))
          (PARAMATERS (|fetch| (TRANSLATION-REC TRANS-PARAMATERS) |of| TRANS-REC))
          (NEW-LINE-INFO-REC (|create| LINE-INFO-REC)))
         (PUSH-ALL-OPERANDS)
         (|replace| (LINE-INFO-REC PATTERN-LIST) |of| NEW-LINE-INFO-REC |with| 
                                                                                      PATTERN-LIST)
         (|replace| (LINE-INFO-REC PARAMETER-LIST) |of| NEW-LINE-INFO-REC |with| 
                                                                                        PARAMATERS)
         (|replace| (LINE-INFO-REC ACTUAL-PARAMETERS) |of| NEW-LINE-INFO-REC
            |with| (|for| PARM |in| PARAMATERS
                          |collect| (PARM-SUBSTITUTE PARM TRANS-REC BYTE-REC NIL NIL)))
         (ADD-OPERAND-LINE PREFIX-STR NEW-LINE-INFO-REC))
    NIL))

(SWAP-PARSER
  (LAMBDA (TRANS-REC BYTE-REC)                           (* \; "Edited 21-Jun-88 14:16 by rtk")
    (DECLARE (SPECIALS *EVAL-STACK* *PREV-UFN*))
    (|if| (AND (GREATERP (LENGTH *EVAL-STACK*)
                          1)
                   (NOT (OR (|fetch| (BYTE-INFO-REC JUMP-TARGET) |of| BYTE-REC)
                            *PREV-UFN*)))
        |then| (LET ((\a (CAR *EVAL-STACK*))
                         (\b (CADR *EVAL-STACK*))
                         (\c (CDDR *EVAL-STACK*)))
                        (SETQ *EVAL-STACK* (CONS \b (CONS \a \c)))
                        NIL)
      |else| (STR-PARSER TRANS-REC BYTE-REC))))

(PVAR_PARSER
  (LAMBDA (TRANS-REC BYTE-REC FN-NAME |optional-string| PC-ADJUST-SIZE)
                                                             (* \; "Edited 23-Jun-88 18:28 by rtk")
    (DECLARE (SPECIAL *EVAL-STACK* *CODE-BASE* *ENTRY-POINTS*))

    (* |;;| "Must Look for PVAR_ of SI::*CATCH-RETURN-PC*")

    (LET
     ((CATCH-PC_ (FASSOC 'SI::*CATCH-RETURN-PC* *VAR-OFFSETS*))
      (PVAR-SLOT (OR (AND (EQ 'PVARX_ (|fetch| (BYTE-INFO-REC OP-NAME) |of| BYTE-REC))
                          (LRSH (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)
                                1))
                     (LOGAND (|fetch| (BYTE-INFO-REC OPCODE) |of| BYTE-REC)
                            7))))
     (|if| (AND CATCH-PC_ (EQ PVAR-SLOT (CADR CATCH-PC_)))
         |then|

         (* |;;| "Adjust the Catch PC")

         (CL:MULTIPLE-VALUE-BIND
          (CATCH-PC CATCH-INFO)
          (OPERAND-POP T)
          (|if| (AND CATCH-PC (EQ 'SMALL-CONST (GET-INFO 'INFO-TYPE CATCH-INFO)))
              |then| (LET ((NEW-CATCH-PC (+ CATCH-PC PC-ADJUST-SIZE)))

                              (* |;;| "Look to the SIC load & fix it with the correct PC")

                              (LET* ((PREVIOUS-PC (|for| PC
                                                     |from| (- (|fetch| (BYTE-INFO-REC PC)
                                                                      |of| BYTE-REC)
                                                                   1) |by| -1
                                                     |thereis| (ELT *ENTRY-POINTS* PC)))
                                     (PREVIOUS-BYTE-REC (ELT *ENTRY-POINTS* PREVIOUS-PC))
                                     (PREVIOUS-OPCODE (|fetch| (BYTE-INFO-REC OP-NAME)
                                                         |of| PREVIOUS-BYTE-REC)))

                                    (* |;;| "fixup the BYTECODES too")

                                    (COND
                                       ((AND (EQ 'SIC PREVIOUS-OPCODE)
                                             (GREATERP 128 NEW-CATCH-PC))
                                        (\\PUTBASEBYTE *CODE-BASE* (+ PREVIOUS-PC 1)
                                               NEW-CATCH-PC))
                                       ((AND (EQ 'SICX PREVIOUS-OPCODE)
                                             (GREATERP 32768 NEW-CATCH-PC))
                                        (\\PUTBASEBYTE *CODE-BASE* (+ PREVIOUS-PC 1)
                                               (LRSH NEW-CATCH-PC 8))
                                        (\\PUTBASEBYTE *CODE-BASE* (+ PREVIOUS-PC 2)
                                               (LOGAND NEW-CATCH-PC 255)))
                                       ((ERROR "Cannot Translate This FN due to CATCH return PC"))))

                              (* |;;| "Mark the Catch PC as an entry point & jump target")

                              (|replace| (BYTE-INFO-REC JUMP-TARGET) |of| (ELT *ENTRY-POINTS*
                                                                                       NEW-CATCH-PC)
                                 |with| T)
                              (OPERAND-PUSH NEW-CATCH-PC CATCH-INFO))
            |else| (ERROR "Non-Constant Use of PC value"))))
     (STR-PARSER TRANS-REC BYTE-REC FN-NAME |optional-string|))))
)



(* |;;| "Pattern Matching  Routines")

(DEFINEQ

(PARM-SUBSTITUTE
  (LAMBDA (PARAMETER TRANS-REC BYTE-REC INFO-TYPE NEW-INFO-TYPE OPTIONAL-REPLACEMENT-VAL)
    (DECLARE (SPECIAL *EVAL-STACK* *ARG-COUNT*))     (* \; "Edited 21-Jun-88 21:02 by rtk")
    (AND INFO-TYPE (SET-INFO 'INFO-TYPE INFO-TYPE))
    (LET* ((PRE-FN (CADR PARAMETER))
           (POST-FN (CADDR PARAMETER))
           (REPLACEMENT-VALUE (OR OPTIONAL-REPLACEMENT-VAL (AND PRE-FN (CL:APPLY PRE-FN
                                                                              (LIST TRANS-REC 
                                                                                    BYTE-REC)))))
           (|str-info| NEW-INFO-TYPE))
          (SETQ *ARG-COUNT* (+ *ARG-COUNT* 1))
          (SETQ REPLACEMENT-VALUE (SELECTQ REPLACEMENT-VALUE
                                      (POP (OR (AND *EVAL-STACK* (CL:MULTIPLE-VALUE-BIND (|value|
                                                                                          |info|)
                                                                        (OPERAND-POP)
                                                                        (SETQ |str-info| |info|)
                                                                        |value|))
                                               (AND (ADD-INFO 'POP-COUNT 1)
                                                    REPLACEMENT-VALUE)
                                               REPLACEMENT-VALUE))
                                      (TOS (OR (CL:MULTIPLE-VALUE-BIND (|value| |info|)
                                                      (OPERAND-GET)
                                                      (SETQ |str-info| |info|)
                                                      |value|)
                                               REPLACEMENT-VALUE))
                                      REPLACEMENT-VALUE))
          (OR (AND POST-FN (CL:APPLY POST-FN (LIST TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE 
                                                   |str-info|)))
              REPLACEMENT-VALUE))))

(TOS-CHECK
  (LAMBDA (TRANS-REC BYTE-REC)
    (DECLARE (SPECIALS *PC-BUMP-SIZE*))              (* \; "Edited 22-Jun-88 03:10 by rtk")
    (LET ((|next-opcode| (|fetch| (BYTE-INFO-REC NEXT-BYTE-REC) |of| BYTE-REC))
          (IS-NCJUMP (FMEMB (FETCH (BYTE-INFO-REC OP-NAME) OF BYTE-REC)
                            '(NTJUMPX NFJUMPX))))
         (COND
            ((AND |next-opcode| (NOT (|fetch| (BYTE-INFO-REC JUMP-TARGET) |of| |next-opcode|)
                                     )
                  (NOT (|fetch| (TRANSLATION-REC MAY-UFN) |of| TRANS-REC))
                  (NOT IS-NCJUMP)
                  (EQ (|fetch| (OPCODENAME) |of| (|fetch| (BYTE-INFO-REC OPCODE-REC)
                                                            |of| |next-opcode|))
                      'POP)
                  (|add| *PC-BUMP-SIZE* 1))

             (* |;;| "Determined if a POP could be used instead of a TOS")

             'POP)
            (T 
               (* |;;| "determine if must push out eval stack before using TOS")

               (* |;;| "this is a hack by putting a space as 1st char in eval stack when it is complicated & shouldn't be repeated")

               (AND (OR (GET-INFO 'POP-COUNT)
                        (LET ((OPERAND (OPERAND-GET)))
                             (IF (TYPEP OPERAND 'LINE-INFO-REC)
                                 THEN (STREQUAL (SUBSTRING (CAR (FETCH (LINE-INFO-REC 
                                                                                      PATTERN-LIST)
                                                                       OF OPERAND))
                                                           1 1)
                                                 " ")
                               ELSE (AND OPERAND (STREQUAL (SUBSTRING OPERAND 1 1)
                                                            " "))))
                        IS-NCJUMP)
                    (PUSH-ALL-OPERANDS))
               'TOS)))))
)



(* |;;| "Output of Code lines")

(DEFINEQ

(ADD-CASE
  (LAMBDA (|pc| |prev-ufn| |jump-target| |negative-jump-target| |can-ufn|)
                                                             (* \; "Edited 21-Jun-88 23:43 by rtk")
    (DECLARE (SPECIALS *ENTRY-POINTS* *START-PC*))
    (|if| (OR |jump-target| |prev-ufn| (AND (GET-INFO 'POP-COUNT)
                                                |can-ufn|))
        |then| (PUSH-ALL-OPERANDS))
    (|if| |jump-target|
        |then| (ADD-LINE (CONCAT "pc" (|if| (MINUSP |pc|)
                                                  |then| (CONCAT "_" (ABS |pc|))
                                                |else| |pc|)
                                        ": ")))
    (|if| (OR |prev-ufn| |jump-target| |negative-jump-target|)
        |then| (LET* ((|entry-case| (CONCAT "case" (PC-XFORM |pc|)))
                          (THIS-ENTRY-POINT (AND (GEQ |pc| *START-PC*)
                                                 (ELT *ENTRY-POINTS* |pc|))))
                         (|if| THIS-ENTRY-POINT
                             |then| (|replace| (BYTE-INFO-REC ENTRY-ADDRESS) |of| 
                                                                                     THIS-ENTRY-POINT
                                           |with| T))
                         (ADD-LINE (CONCAT |entry-case| "_label: " |entry-case| "();"))
                         (ADD-INLINE-LINE (CONCAT ".inline _" |entry-case| ", 0"))
                         (ADD-INLINE-LINE "	" |entry-case| ": ")
                         (ADD-INLINE-LINE ".end ")))
    (|if| |negative-jump-target|
        |then| (ADD-LINE (CONCAT "TIMER_STACK_CHECK(" (BCE-PC |pc| *CODE-BASE*)
                                        ");")
                          T))))

(ADD-PUSH-OPERAND-LINE
  (LAMBDA (LINE-INFO |error-cases| |info-rec|)           (* \; "Edited 21-Jun-88 19:45 by rtk")

    (* |;;| "PUSH the given operand on the Lisp Stack")

    (* |;;| "IF it uses a POP, then do TOS = TOS instead of PUSH(POP)")

    (* |;;| "RETURNS: the new error-stack ")

    (LET ((|error-return| |error-cases|))
         (COND
            ((AND (TYPEP LINE-INFO 'LINE-INFO-REC)
                  (|fetch| (INFO-REC POP-COUNT) |of| |info-rec|)
                  (FMEMB 'POP (|fetch| (LINE-INFO-REC ACTUAL-PARAMETERS) |of| LINE-INFO)))
             (SETQ |error-return| (|bind| (|found-pop| _ NIL) |for| |case| |in| 
                                                                                        |error-cases|
                                     |collect| (OR (AND (NOT |found-pop|)
                                                            (SETQ |found-pop| (EQ 'POP |case|))
                                                            'SAVE_PUSH_TOS)
                                                       |case|)))
             (|replace| (LINE-INFO-REC ACTUAL-PARAMETERS) |of| LINE-INFO
                |with| (REVERSE (|bind| (POP-FOUND _ NIL) |for| PARM
                                       |in| (REVERSE (|fetch| (LINE-INFO-REC 
                                                                             ACTUAL-PARAMETERS)
                                                            |of| LINE-INFO))
                                       |collect| (COND
                                                        ((OR POP-FOUND (NEQ PARM 'POP))
                                                         PARM)
                                                        (T (SETQ POP-FOUND T)
                                                           'TOS)))))
             (ADD-OPERAND-LINE "	TOS = " LINE-INFO ";")

             (* |;;| "Fixup the INLINE-EXPAND re-evaluate call also")

             (|if| *INLINE-ERROR-STACK*
                 |then| (RPLACA *INLINE-ERROR-STACK* (CONS 'TOS (CDAR *INLINE-ERROR-STACK*)))))
            ((TYPEP LINE-INFO 'LINE-INFO-REC)
             (ADD-OPERAND-LINE "	PUSH(" LINE-INFO ");"))
            (T (ADD-OPERAND-LINE "	PUSH(" NIL (CONCAT LINE-INFO ");"))))
         |error-return|)))

(ADD-FN-HEADER-INFO
  (LAMBDA (FN-NAME ENTRY-NAME)                           (* \; "Edited 24-Jun-88 15:30 by rtk")
    (DECLARE (SPECIAL *NUMBER-OF-ARGS* *ENTRY-POINT-MAX* *PVAR-QUAD-SIZE* *STACK-MIN-SIZE* 
                        *CODE-BASE*))
    (SETQ *ENTRY-POINT-MAX* (MAX 5 (ADD1 *NUMBER-OF-ARGS*)))
    (ADD-LINE "#include \"nativeincludes.h\"")
    (ADD-LF)
    (ADD-LINE "#define entry_pc	((int) PC)")
    (ADD-LF)
    (ADD-LINE "LispPTR T_NIL_VALUES[2] = {NIL_PTR, ATOM_T};")
    (ADD-LF)
    (ADD-LINE (CONCAT "int " ENTRY-NAME "()"))
    (ADD-LINE "{")
    (ADD-LF)
    (ADD-LINE "extern int entry_table[255];")
    (ADD-LINE "register LispPTR *CSTKPTR;")
    (ADD-LINE "register LispPTR *IVAR;")
    (ADD-LINE "register LispPTR *PVAR;")
    (ADD-LINE "register LispPTR TOS_CACHE;")
    (ADD-LINE "register LispPTR *DATUM68K;")
    (ADD-LINE "register LispPTR TEMPREG;")
    (ADD-LF)
    (ADD-LINE "goto entrylabel;")
    (ADD-LF)
    (ADD-LINE "entry_table_setup_label:")
    (ADD-LINE "entry_table_setup();")
    (ADD-LF)
    (ADD-LINE "unknown_entry_point: asm(\"unknown_entry_point: \");")
    (ADD-LINE "QUIT_NATIVE(entry_pc + (int)FuncObj);" T)
    (ADD-LF)
    (ADD-LINE "illegal_pc: asm(\"illegal_pc: \");")
    (ADD-LINE "NATIVE_EXT(entry_pc + (int)FuncObj);" T)
    (ADD-LINE "error(\"Illegal PC in native code\");" T)
    (ADD-LINE "asmgoto(&ret_to_dispatch);" T)
    (ADD-LF)
    (ADD-LINE '|include-errors|)
    (ADD-LF)
    (ADD-LINE "entrylabel: ")
    (ADD-LF)

    (* |;;| "This entry point is only executed once, it replaces the native entry address in the code block with the entry code following.")

    (ADD-LINE "entry_point_setup();")
    (ADD-LINE "CSTKPTR = (LispPTR *) CurrentStackPTR;")
    (ADD-LINE "if ((int) entry_pc <= 0) {IVAR = CSTKPTR + (int) entry_pc;}")
    (ADD-LINE "else {IVAR = (LispPTR *) IVar;}")
    (ADD-LINE "PVAR = (LispPTR *) PVar;")
    (ADD-LF)
    (ADD-LINE "switchlabel: ")
    (ADD-LINE (CONCAT "asmgoto(entry_table[entry_pc+" *ENTRY-POINT-MAX* "]);"))
    (ADD-LF)

    (* |;;| "Add Arg Count Dispatch Entry Code")

    (COND
       ((GREATERP 0 *NUMBER-OF-ARGS*)
        (CL-ADD-FN-HEADER-INFO FN-NAME ENTRY-NAME))
       (T (IL-ADD-FN-HEADER-INFO FN-NAME ENTRY-NAME)))

    (* |;;| "Push the PVAR info")

    (ADD-CASE 1 T NIL T)
    (ADD-LINE "{register tempreg = 0x0ffffffff;" T)
    (|if| (|fetch| (FNHEADER CLOSUREP) |of| *CODE-BASE*)
        |then| (ADD-LINE "PUSH(native_closure_env);" T)
              (ADD-LINE "native_closure_env = tempreg;" T)
      |else| (ADD-LINE "PUSH(tempreg);" T))
    (ADD-LINE "PUSH(tempreg);" T)
    (|for| |npvars| |from| 0 |to| *PVAR-QUAD-SIZE* |do| (ADD-LINE 
                                                                               "PUSH(tempreg);" T)
                                                                     (ADD-LINE "PUSH(tempreg);" T
                                                                            ))
    (ADD-LINE "}" T)

    (* |;;| "Add Entry Point for the StartPC")

    (ADD-CASE (|fetch| (FNHEADER STARTPC) |of| *CODE-BASE*)
           T NIL NIL)))

(IL-ADD-FN-HEADER-INFO
  (LAMBDA (FN-NAME ENTRY-NAME)                           (* \; "Edited 23-Jun-88 16:58 by rtk")
    (DECLARE (SPECIAL *NUMBER-OF-ARGS* *ENTRY-POINT-MAX* *PVAR-QUAD-SIZE* *STACK-MIN-SIZE* 
                        *CODE-BASE*))

    (* |;;| " Entry points when we have Too Many/Few arguments")

    (ADD-CASE (MINUS *ENTRY-POINT-MAX*)
           T T)
    (ADD-LINE "{register int i;" T)
    (ADD-LINE (CONCAT "for (i = (-entry_pc) & 0x7f; i > " *NUMBER-OF-ARGS* "; i--) POP; ")
           T)
    (ADD-LINE (CONCAT "STACK_ONLY_CHECK(" (|fetch| (FNHEADER STKMIN) |of| *CODE-BASE*)
                         ");")
           T)
    (ADD-LINE (CONCAT "for (i = (-entry_pc) & 0x7f; i<" *NUMBER-OF-ARGS* "; i++) {")
           T)
    (ADD-LINE "PUSH(NIL_PTR);" T)
    (ADD-LINE "}" T)
    (ADD-LINE (CONCAT (OR (AND (EQ *NUMBER-OF-ARGS* 0)
                                   "goto pc")
                              "goto pc_")
                         *NUMBER-OF-ARGS* ";")
           T)
    (ADD-LINE "}" T)
    (|for| \i |from| (MAX 4 *NUMBER-OF-ARGS*) |to| 0 BY -1
       |do| (COND
                   ((GREATERP \i *NUMBER-OF-ARGS*)
                    (ADD-CASE (MINUS \i)
                           T T)
                    (ADD-LINE "POP;" T)
                    (|if| (EQ (ADD1 *NUMBER-OF-ARGS*)
                                  \i)
                        |then| (ADD-LINE (CONCAT (OR (AND (EQ *NUMBER-OF-ARGS* 0)
                                                                  "goto pc")
                                                             "goto pc_")
                                                        *NUMBER-OF-ARGS* ";")
                                          T)))))

    (* |;;| "Entry points when we have Too Few or Correct arguments")

    (|for| \i |from| 0 |to| (MAX 4 *NUMBER-OF-ARGS*)
       |do| (COND
                   ((GREATERP *NUMBER-OF-ARGS* \i)
                    (ADD-CASE (MINUS \i)
                           T T)
                    (ADD-LINE "PUSH(NIL_PTR);" T))
                   ((EQ *NUMBER-OF-ARGS* \i)
                    (ADD-CASE (MINUS \i)
                           T T)

                    (* |;;| "IVAR IS ALREADY SET IN ENTRY CODE")
                                                             (* ADD-LINE (CONCAT 
                                                           "IVAR = CSTKPTR - " \i ";") T)
                    (ADD-LINE (CONCAT "framesetup(" \i ", " *STACK-MIN-SIZE* ", " (SWAPPED-FN-OBJ
                                                                                       *CODE-BASE*)
                                         ");")
                           T))))))

(CL-ADD-FN-HEADER-INFO
  (LAMBDA (FN-NAME ENTRY-NAME)                           (* \; "Edited 22-Jun-88 18:57 by rtk")
    (DECLARE (SPECIAL *NUMBER-OF-ARGS* *ENTRY-POINT-MAX* *PVAR-QUAD-SIZE* *STACK-MIN-SIZE* 
                        *CODE-BASE*))

    (* |;;| " Entry points when we have Too Many/Few arguments")

    (FOR I FROM (MINUS *ENTRY-POINT-MAX*) TO 0 DO (ADD-CASE I T T))
    (ADD-LINE (CONCAT "framesetup(0, " *STACK-MIN-SIZE* ", " (SWAPPED-FN-OBJ *CODE-BASE*)
                         ");")
           T)))
)



(* |;;| "Low Level Output of  code lines")

(DEFINEQ

(ADD-LINE
  (LAMBDA (|line| |indent|)                              (* \; "Edited 20-Jun-88 17:50 by rtk")
    (ADD-OPERAND-LINE (OR (AND |indent| "        ")
                          "")
           NIL |line|)))

(ADD-OPERAND-LINE
  (LAMBDA (PREFIX-STRING OPERAND-LIST POSTFIX-STRING)
    (DECLARE (SPECIALS *CPROGRAM*))                  (* \; "Edited 20-Jun-88 17:50 by rtk")
    (SETQ *CPROGRAM* (TCONC *CPROGRAM* (|create| LINE-RECORD-INFO
                                              PREFIX-STRING _ PREFIX-STRING
                                              LINE-INFO-LIST _ OPERAND-LIST
                                              POSTFIX-STRING _ POSTFIX-STRING)))))

(ADD-LF
  (LAMBDA NIL                                            (* \; "Edited 17-Feb-88 10:19 by rtk")
    (ADD-LINE " ")))

(ADD-ASM-LINE
  (LAMBDA (|line|)                                       (* \; "Edited 17-Feb-88 11:07 by rtk")
    (ADD-LINE (CONCAT "asm(\"" |line| "\");")
           T)))

(ADD-INLINE-LINE
  (LAMBDA (HEAD-STR LINE-INFO TAIL-STR)
    (DECLARE (SPECIALS *CPROGRAM* *INLINES* *SHOW-INLINE*))
                                                             (* \; "Edited 21-Jun-88 23:30 by rtk")
    (SETQ *INLINES* (TCONC *INLINES* (|create| LINE-RECORD-INFO
                                            PREFIX-STRING _ HEAD-STR
                                            LINE-INFO-LIST _ LINE-INFO
                                            POSTFIX-STRING _ TAIL-STR)))))

(BCE-LINE
  (LAMBDA (PC)                                           (* \; "Edited  7-Mar-88 12:20 by rtk")
    (DECLARE (SPECVARS *CODE-BASE*))
    (CONCAT "BCE(" (BCE-PC PC *CODE-BASE*)
           ");")))
)



(* |;;| "Error Line Functions")

(DEFINEQ

(ADD-ERROR-LINE
  (LAMBDA (HEAD-STR LINE-INFO TAIL-STR)
    (DECLARE (SPECIALS *ERROR-CASES*))               (* \; "Edited 21-Jun-88 11:13 by rtk")
    (SETQ *ERROR-CASES* (TCONC *ERROR-CASES* (|create| LINE-RECORD-INFO
                                                    PREFIX-STRING _ HEAD-STR
                                                    LINE-INFO-LIST _ LINE-INFO
                                                    POSTFIX-STRING _ TAIL-STR)))))

(ADD-ERROR-ENTRY
  (LAMBDA (TRANS-REC BYTE-REC)                           (* \; "Edited 22-Jun-88 00:15 by rtk")
    (DECLARE (SPECIALS *ERROR-STACK* *CODE-BASE* *ARG-COUNT* *ERROR-PC* *INLINE-ERROR-STACK*))

    (* |;;| "*INLINE-ERROR-STACK* format:")

    (* |;;| " (  \"string\"  |  ( [TOS | POP]  LINE-INFO-REC) ) ")

    (* |;;| "*ERROR-STACK* format:")

    (* |;;| " (  )")

    (LET
     ((|pc| (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC)))
     (|if| (|fetch| (TRANSLATION-REC MAY-UFN) |of| TRANS-REC)
         |then|
         (|if| *INLINE-ERROR-STACK*
             |then| (ADD-ERROR-LINE "errorpc" |pc| "_b:")
           |else| (ADD-ERROR-LINE "errorpc" |pc| ":")
                 (ADD-ERROR-LINE "asm(\"errorpc" |pc| ":\");"))
         (LET ((|stack-fix| (AND *ERROR-PC* (SELECTQ *ARG-COUNT*
                                                (0 NIL)
                                                (1 "fixsp1();")
                                                (2 "fixsp2();")
                                                (3 "fixsp3();")
                                                (CONCAT "fixspn(" *ARG-COUNT* ");")))))
              (|if| |stack-fix|
                  |then| (ADD-ERROR-LINE "	" NIL |stack-fix|)))
         (|for| |cases| |in| *ERROR-STACK* |do| (COND
                                                               ((EQ |cases| 'POP)
                                                                (ADD-ERROR-LINE "	" NIL 
                                                                       "CSTKPTR++;"))
                                                               ((EQ |cases| 'TOS)
                                                                NIL)
                                                               ((EQ |cases| 'SAVE_PUSH_TOS)
                                                                NIL)
                                                               ((EQ |cases| 'COPY_TOP)
                                                                (ADD-ERROR-LINE "	" NIL 
                                                                       "PUSH(COPY_TOP);"))
                                                               (T (ADD-ERROR-LINE "	PUSH(" 
                                                                         |cases| ");"))))
         (ADD-ERROR-LINE "	" NIL (BCE-LINE |pc|))
         (|if| *INLINE-ERROR-STACK*
             |then|
             (ADD-ERROR-LINE "errorpc" |pc| ":")
             (ADD-ERROR-LINE "asm(\"errorpc" |pc| ":\");")
             (|for| |cases| |in| *INLINE-ERROR-STACK*
                |do| (COND
                            ((LISTP |cases|)
                             (LET ((THIS-CASE (CDR |cases|)))
                                  (SELECTQ (CAR |cases|)
                                      (PUSH (ADD-ERROR-LINE "	PUSH(" THIS-CASE ");"))
                                      (TOS (LET* ((LINE-INFO (CDR |cases|))
                                                  (PATTERN-LIST (FETCH (LINE-INFO-REC 
                                                                                  PATTERN-LIST)
                                                                   OF LINE-INFO))
                                                  (PARMS (FETCH (LINE-INFO-REC PARAMETER-LIST)
                                                            OF LINE-INFO))
                                                  (ACTUALS (FETCH (LINE-INFO-REC 
                                                                             ACTUAL-PARAMETERS)
                                                              OF LINE-INFO)))
                                                 (REPLACE (LINE-INFO-REC ACTUAL-PARAMETERS)
                                                    OF LINE-INFO
                                                    WITH (|bind| (POP-FOUND _ NIL)
                                                                |for| PARM |in| ACTUALS
                                                                |collect| (COND
                                                                                 ((EQ PARM
                                                                                      'GET_POPPED)
                                                                                  'TOS)
                                                                                 ((EQ PARM
                                                                                      'GET_POPPED_2)
                                                                                  'GET_POPPED)
                                                                                 (T PARM))))
                                                 (ADD-ERROR-LINE "	TOS = " LINE-INFO ";")))
                                      (ADD-ERROR-LINE "	" NIL THIS-CASE))))
                            (T (ADD-ERROR-LINE "	" NIL |cases|)))))))))

(ADD-ERROR-SELECT
  (LAMBDA (ENTRY-NAME)
    (DECLARE (SPECIALS *ERROR-CASES*))               (* \; "Edited  4-Apr-88 19:44 by rtk")
    (LET ((ERROR-PC-STREAM (OPENSTREAM (CONCAT ENTRY-NAME ".h")
                                  'OUTPUT)))
         (PRINTOUT ERROR-PC-STREAM T)
         (PRINTOUT ERROR-PC-STREAM "/* Error Exits for " ENTRY-NAME " */" T)
         (TERPRI ERROR-PC-STREAM)
         (TERPRI ERROR-PC-STREAM)
         (|for| |cases| |in| (CAR *ERROR-CASES*) |do| (PRINTOUT ERROR-PC-STREAM |cases| T
                                                                         ))
         (TERPRI ERROR-PC-STREAM)
         (CLOSEF ERROR-PC-STREAM))))
)



(* |;;| "Low Level Routines")

(DEFINEQ

(FIX-FILENAME
  (LAMBDA (|fn-name|)                                    (* \; "Edited  6-Jun-88 18:28 by rtk")
    (PACK (|for| |letter| |in| (UNPACK (CONCAT 'LISP_TO_C_ (CL:MACHINE-INSTANCE)
                                                      "_" |fn-name|)) |when| (STRPOS |letter| 
                               "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_-\\.,"
                                                                                        )
             |collect| (COND
                              ((EQ |letter| '\\)
                               '|bs_|)
                              ((EQ |letter| '-)
                               '_)
                              ((EQ |letter| '\.)
                               '_)
                              ((EQ |letter| '\,)
                               '_)
                              (T |letter|))))))

(PC-XFORM
  (LAMBDA (|pc|)                                         (* \; "Edited  7-Apr-88 12:07 by rtk")
    (|if| (MINUSP |pc|)
        |then| (CONCAT "_" (ABS |pc|))
      |else| |pc|)))

(BCE-PC
  (LAMBDA (|pc| |fn-base| |numeric|)                     (* \; "Edited 20-May-88 15:08 by rtk")
    (OR (AND |numeric| (+ |pc| (FN-OBJ |fn-base|)))
        (CONCAT "(" |pc| " + " (FN-OBJ |fn-base|)
               ")"))))

(ENVCALL-FN-OBJECT
  (LAMBDA (BYTE-REC)                                     (* \; "Edited 19-May-88 17:02 by rtk")

    (* |;;| "Determine if the Function Pointer to this call is a GCONST.  If it is then Also determine if the GCONST has already been translated, or must be added to the re-translate list.")

    (* |;;| "RETURNS: the GCONST Function Pointer if it must be translated, else NIL.")

    (DECLARE (SPECIAL *ENTRY-POINTS* *START-PC* *FN-OBJECT-REMAP-LIST*))
                                                             (* \; "Edited  8-May-88 11:03 by rtk")
    (LET*
     ((MAX-DESCEND 20)
      (ENVCALL-PC (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC))
      (CURR-PC (SUB1 ENVCALL-PC))
      (FN-OBJECT-ENTRY-LEVEL (IDIFFERENCE (|fetch| (BYTE-INFO-REC ENTRY-STACK-DEPTH) |of|
                                                                                         BYTE-REC)
                                    2))
      (ARG-COUNT-ENTRY-LEVEL (SUB1 FN-OBJECT-ENTRY-LEVEL))
      (LOOP-DONE NIL)
      (RETURN-VALUE NIL)
      (SAW-FN-GCONST NIL))
     (|while| (NOT LOOP-DONE)
        |do|
        (LET* ((THIS-ENTRY (ELT *ENTRY-POINTS* CURR-PC))
               (THIS-ENTRY-STACK-DEPTH (AND THIS-ENTRY (|fetch| (BYTE-INFO-REC ENTRY-STACK-DEPTH)
                                                          |of| THIS-ENTRY))))
              (SETQ LOOP-DONE
               (OR (AND THIS-ENTRY
                        (OR (AND (EQ FN-OBJECT-ENTRY-LEVEL THIS-ENTRY-STACK-DEPTH)
                                 (EQ 'GCONST (|fetch| (BYTE-INFO-REC OP-NAME) |of| THIS-ENTRY
                                                    ))
                                 (LET* ((GCONST-PTR (VAG2 (|fetch| (BYTE-INFO-REC ARG1)
                                                             |of| THIS-ENTRY)
                                                          (LOGOR (LLSH (|fetch| (BYTE-INFO-REC
                                                                                     ARG2)
                                                                          |of| THIS-ENTRY)
                                                                       8)
                                                                 (|fetch| (BYTE-INFO-REC ARG3)
                                                                    |of| THIS-ENTRY))))
                                        (GCONST-INFO (FASSOC GCONST-PTR *FN-OBJECT-REMAP-LIST*))
                                        (GCONST-BEEN-REMAPPED (AND GCONST-INFO (CDR GCONST-INFO))))
                                       (|if| (AND GCONST-BEEN-REMAPPED (|fetch| (FNHEADER
                                                                                         NATIVE)
                                                                              |of| 
                                                                                 GCONST-BEEN-REMAPPED
                                                                                  ))
                                           |then| 

                                                 (* |;;| 
                                               "no need to push the address if native code")

                                                 (|replace| (BYTE-INFO-REC OPCODE) |of|
                                                                                       THIS-ENTRY
                                                    |with| (CAR (\\FINDOP 'NOP)))
                                                 (|replace| (BYTE-INFO-REC OPCODE-PROPS)
                                                    |of| BYTE-REC |with| (LIST 'CODE-CONST 
                                                                                 GCONST-BEEN-REMAPPED
                                                                                       ))
                                                 (SETQ SAW-FN-GCONST T))
                                       (AND (NULL GCONST-BEEN-REMAPPED)
                                            (SETQ RETURN-VALUE GCONST-PTR))))
                            (|fetch| (BYTE-INFO-REC JUMP-TARGET) |of| THIS-ENTRY)
                            (GEQ FN-OBJECT-ENTRY-LEVEL THIS-ENTRY-STACK-DEPTH)))
                   (GREATERP *START-PC* CURR-PC)
                   (GREATERP ENVCALL-PC (IPLUS CURR-PC MAX-DESCEND))))
              (SETQ CURR-PC (SUB1 CURR-PC))))
     (SETQ LOOP-DONE NIL)

     (* |;;| 
   "Look for the number of args being pushed as a constant (if we have a constant code object")

     (|while| (AND SAW-FN-GCONST (NOT RETURN-VALUE)
                       (NOT LOOP-DONE))
        |do| (LET* ((THIS-ENTRY (ELT *ENTRY-POINTS* CURR-PC))
                        (THIS-ENTRY-STACK-DEPTH (AND THIS-ENTRY (|fetch| (BYTE-INFO-REC 
                                                                                    ENTRY-STACK-DEPTH
                                                                                    ) |of| 
                                                                                           THIS-ENTRY
                                                                       ))))
                       (SETQ LOOP-DONE
                        (OR (AND THIS-ENTRY
                                 (OR (AND (EQ ARG-COUNT-ENTRY-LEVEL THIS-ENTRY-STACK-DEPTH)
                                          (FMEMB (|fetch| (BYTE-INFO-REC OP-NAME) |of| 
                                                                                           THIS-ENTRY
                                                        )
                                                 '(SIC \'1 \'0))
                                          (LET* ((OPCODE-NAME (|fetch| (BYTE-INFO-REC OP-NAME)
                                                                 |of| THIS-ENTRY))
                                                 (NUM-OF-ARGS (COND
                                                                 ((EQ '\'1 OPCODE-NAME)
                                                                  1)
                                                                 ((EQ '\'0 OPCODE-NAME)
                                                                  0)
                                                                 (T (|fetch| (BYTE-INFO-REC
                                                                                  ARG1) |of|
                                                                                        THIS-ENTRY)))
                                                        ))

                                                (* |;;| "Don't have to push a num of args")

                                                (|replace| (BYTE-INFO-REC OPCODE) |of| 
                                                                                           THIS-ENTRY
                                                   |with| (CAR (\\FINDOP 'NOP)))
                                                (|replace| (BYTE-INFO-REC OPCODE-PROPS)
                                                   |of| BYTE-REC
                                                   |with| (CONS 'ARG-CONST
                                                                    (CONS NUM-OF-ARGS
                                                                          (|fetch| (BYTE-INFO-REC
                                                                                        OPCODE-PROPS)
                                                                             |of| BYTE-REC))))
                                                T))
                                     (|fetch| (BYTE-INFO-REC JUMP-TARGET) |of| THIS-ENTRY)
                                     (GEQ ARG-COUNT-ENTRY-LEVEL THIS-ENTRY-STACK-DEPTH)))
                            (GREATERP *START-PC* CURR-PC)
                            (GREATERP ENVCALL-PC (IPLUS CURR-PC MAX-DESCEND))))
                       (SETQ CURR-PC (SUB1 CURR-PC))))
     RETURN-VALUE)))

(FIND-FN0-OBJECTS
  (LAMBDA (ENVCALL-LIST)                                 (* \; "Edited 19-May-88 10:36 by rtk")

    (* |;;| "look throuth the list of envcalls.  Return a list of those which have constant function objects which have not been translated yet.")

    (LET ((FN-OBJECT-LIST NIL))
         (|for| BYTE-REC |in| ENVCALL-LIST |do| (LET ((FN-TO-TRANSLATE (
                                                                                  ENVCALL-FN-OBJECT
                                                                                    BYTE-REC)))
                                                                 (|if| FN-TO-TRANSLATE
                                                                     |then| (|push| 
                                                                                       FN-OBJECT-LIST
                                                                                       
                                                                                      FN-TO-TRANSLATE
                                                                                       ))))
         FN-OBJECT-LIST)))

(CONST-POINTERP
  (LAMBDA (\x)
    NIL))

(MAKE-VAR-OFFSETS
  (LAMBDA (CODE-BASE)
    (DECLARE (USEDFREE CODEBASE IVARS PVARS FVARS I4 I6 OUTF))
                                                             (* \; "Edited 23-Jun-88 18:09 by rtk")

    (* |;;| "Return List of (Symbol Name,  Slot Offset ,  Access Type )")

    (LET ((START1 (UNFOLD (|fetch| (FNHEADER OVERHEADWORDS) |of| T)
                         BYTESPERWORD))
          (START2 (UNFOLD (|fetch| (FNHEADER NTSIZE) |of| CODE-BASE)
                         BYTESPERWORD))
          VAR-LIST NAME TAG THEELT)
         (COND
            ((ILESSP START1 (SETQ START2 (IPLUS START2 START1)))
             (|for| NT1 |from| START1 |by| BYTESPERWORD |while| (ILESSP NT1 START2)
                |as| NT2 |from| START2 |by| BYTESPERWORD
                |do| (COND
                            ((SETQ NAME (\\INDEXATOMVAL (CODEBASELT2 CODE-BASE NT1)))
                             (SETQ TAG (CODEBASELT CODE-BASE (ADD1 NT2)))
                             (SETQ THEELT (CODEBASELT CODE-BASE NT2))
                             (|push| VAR-LIST (LIST NAME TAG (SELECTC THEELT
                                                                     ((LRSH IVARCODE 8) 
                                                                          'IVAR)
                                                                     ((LRSH PVARCODE 8) 
                                                                          'PVAR)
                                                                     'FVAR))))))))
         VAR-LIST)))
)



(* |;;| "Deferred Stack Funcions")

(DEFINEQ

(NEXT-OPERAND
  (LAMBDA NIL                                            (* \; "Edited 27-Apr-88 21:25 by rtk")

    (* |;;| "Get the Next operand for a binary operation, keeping numeric constants")

    (DECLARE (SPECIALS *EVAL-STACK*))
    (OR (OPERAND-POP T)
        'POP)))

(PUSH-ALL-OPERANDS
  (LAMBDA NIL                                            (* \; "Edited 28-Apr-88 15:02 by rtk")
    (DECLARE (SPECIAL *EVAL-STACK*))
    (SETQ *EVAL-STACK* (REVERSE *EVAL-STACK*))
    (|while| *EVAL-STACK* |do| (CL:MULTIPLE-VALUE-BIND (|operand| |info-rec|)
                                              (OPERAND-POP)
                                              (ADD-PUSH-OPERAND-LINE |operand| NIL |info-rec|)))))

(OPERAND-PUSH
  (LAMBDA (LINE-INFO |info|)                             (* \; "Edited 21-Jun-88 19:42 by rtk")
    (DECLARE (SPECIALS *EVAL-STACK*))
    (AND (GET-INFO 'POP-COUNT)
         (PUSH-ALL-OPERANDS))
    (COND
       ((AND (TYPEP LINE-INFO 'LINE-INFO-REC)
             (EQ (LENGTH (|fetch| (LINE-INFO-REC PATTERN-LIST) |of| LINE-INFO))
                 1)
             (EQ (LENGTH (|fetch| (LINE-INFO-REC PARAMETER-LIST) |of| LINE-INFO))
                 1))

        (* |;;| "turn LINE-INFO-RECS back into constants when you can")

        (|push| *EVAL-STACK* (CONS (CAR (|fetch| (LINE-INFO-REC ACTUAL-PARAMETERS)
                                               |of| LINE-INFO))
                                       |info|)))
       (T (|push| *EVAL-STACK* (CONS LINE-INFO |info|))))))

(OPERAND-GET
  (LAMBDA (|keep-constants|)                             (* \; "Edited  7-May-88 10:53 by rtk")
    (DECLARE (SPECIALS *EVAL-STACK*))
    (LET* ((|operand| (AND *EVAL-STACK* (CAR *EVAL-STACK*)))
           (|operand-string| (AND |operand| (CAR |operand|)))
           (|operand-info| (AND |operand| (CDR |operand|)))
           (|operand-val| (AND |operand| (OR (AND |keep-constants| |operand-string|)
                                             (GET-VAL |operand-string| |operand-info|)))))
          (CL:VALUES |operand-val| |operand-info|))))

(OPERAND-POP
  (LAMBDA (|keep-constants|)                             (* \; "Edited 24-May-88 10:25 by rtk")
    (DECLARE (SPECIAL *EVAL-STACK*))
    (CL:MULTIPLE-VALUE-PROG1 (OPERAND-GET |keep-constants|)
           (AND *EVAL-STACK* (|pop| *EVAL-STACK*)))))

(GET-VAL
  (LAMBDA (\x |operand-info|)                            (* \; "Edited 24-May-88 10:48 by rtk")
    (|if| (AND (NUMBERP \x)
                   (EQ (|fetch| (INFO-REC INFO-TYPE) |of| |operand-info|)
                       'SMALL-CONST))
        |then| (|if| (GEQ \x 0)
                       |then| (CONCAT "(S_POSITIVE | " \x ")")
                     |else| (CONCAT "(S_NEGATIVE | " (LOGAND \x 65535)
                                       ")"))
      |else| \x)))

(GET-SHIFTED-VAL
  (LAMBDA (\x |shiftcount|)                              (* \; "Edited 18-Feb-88 17:05 by rtk")
    (|if| (NUMBERP \x)
        |then| (LOGAND (LLSH \x |shiftcount|)
                          4294934528)
      |else| \x)))

(GET-INFO
  (LAMBDA (|prop| |info|)                                (* \; "Edited  7-May-88 10:46 by rtk")
    (DECLARE (SPECIAL *EVAL-STACK*))
    (LET ((|stack-pos| (OR |info| (AND *EVAL-STACK* (CDAR *EVAL-STACK*)))))
         (AND |stack-pos| (SELECTQ |prop|
                              (POP-COUNT (|fetch| (INFO-REC POP-COUNT) |of| |stack-pos|))
                              (INFO-TYPE (|fetch| (INFO-REC INFO-TYPE) |of| |stack-pos|))
                              NIL)))))

(ADD-INFO
  (LAMBDA (|prop| |val|)
    (DECLARE (SPECIAL *INFO-REC*))                   (* \; "Edited 29-Apr-88 11:05 by rtk")
    (LET ((|oldvalue| (OR (AND *INFO-REC* (GET-INFO |prop| *INFO-REC*))
                          (AND (SETQ *INFO-REC* (|create| INFO-REC
                                                       POP-COUNT _ 0))
                               0))))
         (SET-INFO |prop| (IPLUS |val| |oldvalue|)))))

(SET-INFO
  (LAMBDA (|prop| |val|)
    (DECLARE (SPECIAL *INFO-REC*))                   (* \; "Edited  7-May-88 10:47 by rtk")
    (OR *INFO-REC* (SETQ *INFO-REC* (|create| INFO-REC)))
    (SELECTQ |prop|
        (POP-COUNT (|replace| (INFO-REC POP-COUNT) |of| *INFO-REC* |with| |val|))
        (INFO-TYPE (|replace| (INFO-REC INFO-TYPE) |of| *INFO-REC* |with| |val|))
        NIL)))
)



(* |;;| "Writeout Files")

(DEFINEQ

(MAKE-PROGRAM-FILE
  (LAMBDA (|file-name| |keep-cr-eol|)                (* \; "Edited 19-Apr-88 18:56 by Krivacic")
    (LET ((|namec| (CONCAT |file-name| ".c"))
          (|nameil| (CONCAT |file-name| ".il")))
         (WRITE-PROGRAM-FILE |file-name| |namec| |keep-cr-eol|)
         (WRITE-INLINE-FILE |file-name| |nameil| |keep-cr-eol|))))

(WRITE-PROGRAM-FILE
  (LAMBDA (|file-name| |namec| |keep-cr-eol|)            (* \; "Edited 21-Jun-88 20:31 by rtk")

    (* |;;| "Printout the inline assembly file")

    (DECLARE (SPECIAL *CPROGRAM*))
    (LET* ((|full-file-name| (OR (AND (EQ 'MAIKO (MACHINETYPE))
                                      (CONCAT "{UNIX}" IL:*NATIVE-TEMP-FILE-DIRECTORY* "/" |namec|))
                                 |namec|))
           (|stream| (OR (AND |file-name| (OPENSTREAM |full-file-name| 'OUTPUT 'NEW
                                                 '((EOL LF))))
                         T)))
          (PRINTOUT *NATIVE-STREAM* "Writing Native File: " |full-file-name| T)
          (|if| (AND (NOT |keep-cr-eol|)
                         (NEQ |stream| T))
              |then| (SETFILEINFO |stream| 'EOL 'LF))
          (|for| |line| |in| (CAR *CPROGRAM*) |as| I |from| 0
             |do| (PRINT-CODE-LINE |stream| |line|)
                   (|if| (EQ 0 (LOGAND I 15))
                       |then| (BLOCK)))
          (|if| (NEQ |stream| T)
              |then| (CLOSEF |stream|)))))

(WRITE-INLINE-FILE
  (LAMBDA (|file-name| |nameil| |keep-cr-eol|)           (* \; "Edited 21-Jun-88 20:30 by rtk")

    (* |;;| "Printout the inline assembly file")

    (DECLARE (SPECIAL *INLINES* *CODE-SIZE* *ENTRY-POINT-MAX* *CODE-BASE* *START-PC*))
    (LET* ((|full-file-name| (OR (AND (EQ 'MAIKO (MACHINETYPE))
                                      (CONCAT "{UNIX}" IL:*NATIVE-TEMP-FILE-DIRECTORY* "/" |nameil|))
                                 |nameil|))
           (|stream| (OR (AND |file-name| (OPENSTREAM |full-file-name| 'OUTPUT 'NEW
                                                 '((EOL LF))))
                         T)))
          (PRINTOUT *NATIVE-STREAM* "Writing Inline File: " |full-file-name| T)
          (|if| (AND (NOT |keep-cr-eol|)
                         (NEQ |stream| T))
              |then| (SETFILEINFO |stream| 'EOL 'LF))

          (* |;;| "Write the InLine Defs")

          (|for| |line| |in| (CAR *INLINES*) |as| I |from| 0
             |do| (PRINT-CODE-LINE |stream| |line|)
                   (|if| (EQ 0 (LOGAND I 15))
                       |then| (BLOCK)))

          (* |;;| "Write the Entry Point Table")

          (PRINTOUT |stream| ".inline _entry_table_setup,0" T)
          (PRINTOUT |stream| "_entry_table:" T)
          (|for| \i |from| (MINUS *ENTRY-POINT-MAX*) |to| 0
             |do| (PRINTOUT |stream| "	.long case" (PC-XFORM \i)
                             T))
          (PRINTOUT |stream| "	.long case" (PC-XFORM 1)
                 T)
          (|for| \i |from| 2 |to| (SUB1 *CODE-SIZE*)
             |do| (LET ((ENTRY-POINT (ELT *ENTRY-POINTS* \i)))
                           (COND
                              ((OR (EQ \i (|fetch| (FNHEADER STARTPC) |of| *CODE-BASE*))
                                   (AND (TYPEP ENTRY-POINT 'BYTE-INFO-REC)
                                        (|fetch| (BYTE-INFO-REC ENTRY-ADDRESS) |of| 
                                                                                         ENTRY-POINT)
                                        ))
                               (PRINTOUT |stream| "	.long case" (PC-XFORM \i)
                                      T))
                              (ENTRY-POINT (PRINTOUT |stream| "	.long unknown_entry_point" T))
                              (T (PRINTOUT |stream| "	.long illegal_pc" T))))
                   (BLOCK))
          (PRINTOUT |stream| ".end" T)
          (PRINTOUT |stream| T)
          (PRINTOUT |stream| ".inline _entry_point_setup,0" T)
          (PRINTOUT |stream| "	unlk a6" T)
          (PRINTOUT |stream| "	lea entry_point,a0" T)
          (PRINTOUT |stream| "	movl a0," (OR (AND (EQ 'MAIKO (MACHINETYPE))
                                                  (SUBRCALL GET-NATIVE-ADDR-FROM-LISP-PTR *CODE-BASE*
                                                         ))
                                             (FN-OBJ *CODE-BASE*))
                 " + " *START-PC* " - 4" T)
          (PRINTOUT |stream| "entry_point: " T)
          (PRINTOUT |stream| ".end" T)
          (PRINTOUT |stream| T)
          (|if| (NEQ |stream| T)
              |then| (CLOSEF |stream|)))))

(WRITE-INCLUDE-FILE
  (LAMBDA (ERROR-PC-STREAM)                              (* \; "Edited 21-Jun-88 20:31 by rtk")

    (* |;;| "Printout the include file of error exits")

    (DECLARE (SPECIALS *INLINES* *CODE-SIZE*))
    (PRINTOUT ERROR-PC-STREAM T)
    (PRINTOUT ERROR-PC-STREAM "/* Error Exits */" T)
    (TERPRI ERROR-PC-STREAM)
    (TERPRI ERROR-PC-STREAM)
    (|for| |cases| |in| (CAR *ERROR-CASES*) |as| I |from| 0
       |do| (PRINT-CODE-LINE ERROR-PC-STREAM |cases|)
             (|if| (EQ 0 (LOGAND I 15))
                 |then| (BLOCK)))
    (TERPRI ERROR-PC-STREAM)))

(PRINT-CODE-LINE
  (LAMBDA (STREAM LINE)                                  (* \; "Edited 21-Jun-88 23:44 by rtk")
    (COND
       ((TYPEP LINE 'LINE-RECORD-INFO)
        (COND
           ((EQ '|include-errors| (|fetch| (LINE-RECORD-INFO POSTFIX-STRING) |of| LINE))
            (WRITE-INCLUDE-FILE STREAM))
           (T (LET ((PREFIX (|fetch| (LINE-RECORD-INFO PREFIX-STRING) |of| LINE))
                    (LINE-INFO (|fetch| (LINE-RECORD-INFO LINE-INFO-LIST) |of| LINE))
                    (POSTFIX (|fetch| (LINE-RECORD-INFO POSTFIX-STRING) |of| LINE)))
                   (AND PREFIX (PRINTOUT STREAM PREFIX))
                   (AND LINE-INFO (PRINT-LINE-INFO STREAM LINE-INFO))
                   (AND POSTFIX (PRINTOUT STREAM POSTFIX))
                   (TERPRI STREAM)))))
       (T (PRINTOUT STREAM LINE T)))))

(PRINT-LINE-INFO
  (LAMBDA (STREAM LINE-INFO)                             (* \; "Edited 21-Jun-88 19:29 by rtk")
    (AND LINE-INFO
         (COND
            ((TYPEP LINE-INFO 'LINE-INFO-REC)
             (LET ((LINE-PATTERN (|fetch| (LINE-INFO-REC PATTERN-LIST) |of| LINE-INFO))
                   (FORMAL-PARMS (|fetch| (LINE-INFO-REC PARAMETER-LIST) |of| LINE-INFO))
                   (ACTUAL-PARMS (|fetch| (LINE-INFO-REC ACTUAL-PARAMETERS) |of| LINE-INFO)))
                  (|for| PAT |in| LINE-PATTERN
                     |do| (COND
                                 ((LITATOM PAT)

                                  (* |;;| "Must replace formal parm with actual parm")

                                  (LET ((ACTUAL-LINE (OR (|for| ACTUAL-PARM |in| ACTUAL-PARMS
                                                            |as| FORMAL-PARM |in| 
                                                                                       FORMAL-PARMS
                                                            |thereis| (AND (EQ (CAR FORMAL-PARM)
                                                                                   PAT)))
                                                         PAT)))
                                       (|if| (TYPEP ACTUAL-LINE 'LINE-INFO-REC)
                                           |then| (PRINT-LINE-INFO STREAM ACTUAL-LINE)
                                         |else| (PRINTOUT STREAM ACTUAL-LINE))))
                                 (T 
                                    (* |;;| "Output the Current String")

                                    (PRINTOUT STREAM PAT))))))
            (T (PRINTOUT STREAM LINE-INFO))))))
)



(* |;;| "Initialization")

(DEFINEQ

(TRANSLATION-INIT
  (LAMBDA (|force-init|)                                 (* \; "Edited 21-Jun-88 19:07 by rtk")
    (DECLARE (SPECIAL *CPROGRAM* *ENTRY-POINTS* *TRANSLATION-TABLE* 
                        IL:*NATIVE-TEMP-FILE-DIRECTORY* IL:*NATIVE-INCLUDE-FILE-DIRECTORY* 
                        IL:*NATIVE-LISP-RUN-FILENAME* IL:*NATIVE-BIN-DIRECTORY*))
    (SETQ IL:*NATIVE-TEMP-FILE-DIRECTORY* (STRIP-ENDING-SLASH IL:*NATIVE-TEMP-FILE-DIRECTORY*))
    (SETQ IL:*NATIVE-INCLUDE-FILE-DIRECTORY* (STRIP-ENDING-SLASH 
                                                    IL:*NATIVE-INCLUDE-FILE-DIRECTORY*))
    (SETQ IL:*NATIVE-BIN-DIRECTORY* (STRIP-ENDING-SLASH IL:*NATIVE-BIN-DIRECTORY*))
    (SETQ *CPROGRAM* NIL)
    (SETQ *ENTRY-POINTS* (ARRAY 4000 'POINTER NIL 0))
    (|if| (OR |force-init| (NOT (BOUNDP '*NATIVE-TRANSLATION-TABLE*)))
        |then| (SETQ *TRANSLATION-TABLE* (ARRAY 256 'POINTER NIL 0))
              (SETQ *NATIVE-TRANSLATION-TABLE* *TRANSLATION-TABLE*) 

              (* |;;| "ARGS:  pattern may-ufn stack-args pushing-result defer-push parse-fn inline-exit-fn inline-expansion")

              (LET ((ORDERING-LIST (MAKE-ORDERING-LIST))
                    (OPCODE-LIST (MAKE-OPCODE-LIST)))
                   (MAKE-TRANSLATION-ENTRIES OPCODE-LIST ORDERING-LIST))
      |else| (SETQ *TRANSLATION-TABLE* *NATIVE-TRANSLATION-TABLE*))))

(STRIP-ENDING-SLASH
  (LAMBDA (FILE-NAME)                                    (* \; "Edited 17-Jun-88 18:45 by rtk")
    (LET ((POS (STRPOS "/" FILE-NAME NIL NIL NIL NIL NIL T)))
         (COND
            ((EQ POS (NCHARS FILE-NAME))
             (SUBSTRING FILE-NAME 1 (- POS 1)))
            (T FILE-NAME)))))

(SETUP-TRANSLATION-FNS
  (LAMBDA NIL                                            (* \; "Edited  2-May-88 18:01 by rtk")
    (DECLARE (SPECIAL *BYTE-INFO-TABLE* *CODE-SIZE*))
    (SETQ *BYTE-INFO-TABLE* (ARRAY *CODE-SIZE* 'POINTER NIL 0))))

(MAKE-TRANSLATION-ENTRY
  (LAMBDA (|entry| ORDERING-LIST)                        (* \; "Edited 22-Jun-88 00:30 by rtk")
    (DECLARE (SPECIALS *TRANSLATION-TABLE*))
    (|if| (NEQ '* (CAR |entry|))
        |then| (DESTRUCTURING-BIND
                    (|opcode| |pattern| |may-ufn| |stack-args| |pushing-result| |defer-push| 
                           |parse-fn| |inline-exit-fn| |inline-expansion|)
                    |entry|
                    (LET ((|opcode-info| (\\FINDOP |opcode|)))
                         (|if| |opcode-info|
                             |then| (LET* ((|opcode-range| (|fetch| OP# |of| 
                                                                                      |opcode-info|))
                                               (|opcodes| (OR (AND (LISTP |opcode-range|)
                                                                   |opcode-range|)
                                                              (LIST |opcode-range| |opcode-range|)))
                                               (|level-adjust| (OR (|fetch| LEVADJ |of|
                                                                                       |opcode-info|)
                                                                   0))
                                               (*ARG-COUNT* 0))
                                              (DECLARE (SPECVAR *ARG-COUNT*))
                                              (|bind| |tran-rec| |for| |opcode|
                                                 |from| (CAR |opcodes|) |to| (CADR |opcodes|)
                                                 |do| (SETQ |tran-rec| (|create| 
                                                                                  TRANSLATION-REC))
                                                       (|replace| (TRANSLATION-REC MAY-UFN)
                                                          |of| |tran-rec| |with| |may-ufn|)
                                                       (|replace| (TRANSLATION-REC STACK-ARGS)
                                                          |of| |tran-rec| |with| (OR 
                                                                                         |stack-args|
                                                                                             0))
                                                       (|replace| (TRANSLATION-REC PUSHING-RESULT
                                                                             ) |of| |tran-rec|
                                                          |with| |pushing-result|)
                                                       (|replace| (TRANSLATION-REC DEFER-PUSH)
                                                          |of| |tran-rec| |with| |defer-push|
                                                              )
                                                       (|replace| (TRANSLATION-REC PATTERN)
                                                          |of| |tran-rec| |with| |pattern|)
                                                       (|replace| (TRANSLATION-REC STACK-ADJUST)
                                                          |of| |tran-rec| |with| 
                                                                                    |level-adjust|)
                                                       (|replace| (TRANSLATION-REC PARSE-FN)
                                                          |of| |tran-rec|
                                                          |with| (OR |parse-fn| 'STR-PARSER))
                                                       (|replace| (TRANSLATION-REC INLINE-EXIT-FN
                                                                             ) |of| |tran-rec|
                                                          |with| |inline-exit-fn|)
                                                       (|replace| (TRANSLATION-REC 
                                                                             INLINE-EXPANSIONS)
                                                          |of| |tran-rec| |with| (
                                                                                  MAKE-INLINE-LISTS
                                                                                          
                                                                                   |inline-expansion|
                                                                                          
                                                                                        ORDERING-LIST
                                                                                          ))
                                                       (|replace| (TRANSLATION-REC POPPING-TOS)
                                                          |of| |tran-rec| |with| (STRPOS
                                                                                          "$(Tos)" 
                                                                                          |pattern|))
                                                       (CL:MULTIPLE-VALUE-BIND (PATTERN-LIST 
                                                                                      PARAMETER-LIST)
                                                              (MAKE-TRANSLATION-PATTERN-LIST
                                                               |pattern| ORDERING-LIST)
                                                              (|replace| (TRANSLATION-REC 
                                                                                    TRANS-PATTERN)
                                                                 |of| |tran-rec| |with|
                                                                                     PATTERN-LIST)
                                                              (|replace| (TRANSLATION-REC 
                                                                                    TRANS-PARAMATERS)
                                                                 |of| |tran-rec| |with|
                                                                                     PARAMETER-LIST))
                                                       (SETA *TRANSLATION-TABLE* |opcode| |tran-rec|)
                                                     ))
                           |else| (PRINTOUT T "Opcode " |opcode| " not found." T)))))
    (BLOCK)))

(MAKE-TRANSLATION-ENTRIES
  (LAMBDA (|entry-list| ORDERING-LIST)                   (* \; "Edited 21-Jun-88 19:07 by rtk")
    (|for| |entry| |in| |entry-list| |do| (MAKE-TRANSLATION-ENTRY |entry| 
                                                             ORDERING-LIST))))

(MAKE-TRANSLATION-PATTERN-LIST
  (LAMBDA (STRING-PATTERN ORDERING-LIST)                 (* \; "Edited 21-Jun-88 19:37 by rtk")

(* |;;;| "Turn the String into a list format used in  the translator of")

(* |;;;| "( (\"str\" | replacement-symbol)     (ordering of replacement symbols) )")

    (LET ((PRINT-LIST NIL)
          (PARAMETER-LIST NIL)
          (DOLLAR-POS NIL)
          (ORDERED-PARAMETER-LIST NIL))

         (* |;;| "Break up the string into sections ")

         (SETQ PRINT-LIST (|while| (SETQ DOLLAR-POS (STRPOS "$" STRING-PATTERN))
                             |join| (LET* ((HEAD (SUBSTRING STRING-PATTERN 1 (SUB1 DOLLAR-POS)))
                                               (TEMP-TAIL (SUBSTRING STRING-PATTERN DOLLAR-POS))
                                               (FOUND-PARM (|for| PARM |in| ORDERING-LIST
                                                              |thereis|
                                                              (EQ 1 (STRPOS (CAR PARM)
                                                                           TEMP-TAIL))))
                                               (TAIL (SUBSTRING TEMP-TAIL (+ (NCHARS (CAR FOUND-PARM)
                                                                                    )
                                                                             1))))
                                              (SETQ PARAMETER-LIST (CONS FOUND-PARM PARAMETER-LIST))
                                              (SETQ STRING-PATTERN TAIL)
                                              (OR (AND HEAD (LIST HEAD (CADR FOUND-PARM)))
                                                  (LIST (CADR FOUND-PARM))))))
         (|if| STRING-PATTERN
             |then| (SETQ PRINT-LIST (APPEND PRINT-LIST (LIST STRING-PATTERN))))

         (* |;;| "Order the Parameter List")

         (|for| PARAMETER |in| (REVERSE ORDERING-LIST)
            |do| (|if| (FMEMB PARAMETER PARAMETER-LIST)
                         |then| (SETQ ORDERED-PARAMETER-LIST (CONS (CDR PARAMETER)
                                                                       ORDERED-PARAMETER-LIST))))

         (* |;;| "return ( ( pattern list)  (parameter list))")

         (CL:VALUES PRINT-LIST ORDERED-PARAMETER-LIST))))

(MAKE-INLINE-LISTS
  (LAMBDA (EXPANSION-LIST ORDERING-LIST)                 (* \; "Edited 21-Jun-88 19:07 by rtk")
    (|for| MACHINE-TYPE-LIST |on| EXPANSION-LIST |by| (CDDR EXPANSION-LIST)
       |join| (LIST (CAR MACHINE-TYPE-LIST)
                        (|for| EXPANSION-STRING |in| (CADR MACHINE-TYPE-LIST)
                           |collect| (CL:MULTIPLE-VALUE-BIND (V-HEAD V-TAIL)
                                                (MAKE-TRANSLATION-PATTERN-LIST EXPANSION-STRING 
                                                       ORDERING-LIST)
                                                (LIST V-HEAD V-TAIL)))))))

(MAKE-OPCODE-LIST
  (LAMBDA NIL                                            (* \; "Edited 24-Jun-88 16:33 by rtk")

    (* |;;| "ARGS:  pattern may-ufn stack-args pushing-result defer-push parse-fn inline-exit-fn inline-expansion")

    '(
      (* |;;| "Variable Reference")

      (IVAR "IVAR[$op<3>]" NIL 0 T T STR-PARSER)
      (IVARX "IVAR[$x/2]" NIL 0 T T STR-PARSER)
      (IVARX_ "IVAR[$x/2] = $Tos " NIL 1 NIL NIL STR-PARSER)
      (PVAR "PVAR[$op<3>]" NIL 0 T T STR-PARSER)
      (PVAR_ "PVAR[$op<3>] = $Tos " NIL 1 NIL NIL PVAR_PARSER)
      (PVAR_^
       "PVAR[$op<3>] = $(Tos) " NIL 1 NIL NIL PVAR_PARSER)
      (PVARX "PVAR[$x/2]" NIL 0 T T STR-PARSER)
      (PVARX_ "PVAR[$x/2] = $Tos " NIL 1 NIL NIL PVAR_PARSER)
      (GVAR_ "N_OP_gvar_($Tos, $x16)" NIL 1 NIL NIL STR-PARSER)
      (GVAR " (GetLongWord(Valspace + $x16<<1))" NIL 0 T T STR-PARSER)
      (FVAR " N_OP_fvarn($op<3><<1)" NIL 0 T NIL STR-PARSER)
      (FVARX " N_OP_fvarn($x)" NIL 0 T NIL STR-PARSER)
      (FVARX_ "N_OP_fvar_($(Tos), $x)" NIL 1 T NIL STR-PARSER)

      (* |;;| "Stack Operations")

      (COPY "COPY_TOP" NIL 1 T T COPY-PARSER)
      (SWAP "{LispPTR temp = TOS; TOS = PREV_TOS; PREV_TOS = temp;}" NIL 2 NIL NIL SWAP-PARSER)
      (POP "$(Tos)" NIL 1 NIL NIL STR-PARSER)
      (POP.N "CSTKPTR = CSTKPTR - ($x)" T 0 NIL NIL STR-PARSER)
      (COPY.N " *(CSTKPTR - ($x/2 + 1))" T 0 T NIL STR-PARSER)
      (STORE.N " *(CSTKPTR - ($x/2 + 1)) = TOS" T 1 T NIL STR-PARSER)
      (FINDKEY "N_OP_findkey($(Tos), $x)" NIL 1 T T STR-PARSER)
      (BIND "CSTKPTR = (LispPTR *) N_OP_bind(CSTKPTR, $(Tos), $x, $x2) + 1" T 1 NIL NIL 
             STR-PARSER)
      (UNBIND 
  "{register LispPTR SAVE_TOS = $(Tos); CSTKPTR = (LispPTR *) N_OP_unbind(CSTKPTR); PUSH(SAVE_TOS);}"
             T 0 NIL NIL STR-PARSER)
      (DUNBIND "CSTKPTR = (LispPTR *) N_OP_dunbind(CSTKPTR, $Tos)" T 1 NIL NIL STR-PARSER)
                                                             (* UNWIND 
                                                     "CALL_OP_FN($bce-pc, $next-bce-pc, OP_unwind)"
    T 0 NIL NIL STR-PARSER)
      (UNWIND "CSTKPTR = (LispPTR *) N_OP_unwind($CSTKPTR, $(Tos), $x, $x2, $errorpc) + 1" T 1 NIL 
             NIL STR-PARSER)
      (MYALINK " ((((NATIVE_CURRENTFX->alink) & 0xfffe) - FRAMESIZE) | S_POSITIVE)" NIL 0 T T 
             STR-PARSER)
      (ARG0 "N_OP_arg0($(Tos), $errorpc)" T 0 T NIL STR-PARSER)
      (MYARGCOUNT "MYARGCOUNT" T 0 NIL NIL STR-PARSER NIL NIL)
      (STKSCAN "N_OP_stkscan($(Tos), $errorpc)" T 1 T NIL STR-PARSER)

      (* |;;| "Arithmetic Operations")

      (DIFFERENCE "N_OP_difference($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER NIL
             (SUN3.N ("DIFFERENCE_N_$pc($(Tos-1))" "movl a7@+,d0" "moveq #15,d2" "roll d2,d0" 
                            "subqb #7,d0" "bne $errorpc " "subl #$#(Tos<<15),d0 " "bvs $errorpc " 
                            "lsrl d2,d0" "orl #0x000E0000,d0")
                    SUN3
                    ("DIFFERENCE_$pc($(Tos-1), $(Tos))" "movl a7@+,d0" "movl a7@+,d1" "moveq #15,d2"
                           "roll d2,d0" "subqb #7,d0" "bne $errorpc " "roll d2,d1" "subqb #7,d1" 
                           "bne $errorpc " "subl d1,d0 " "bvs $errorpc " "lsrl d2,d0" 
                           "orl #0x000E0000,d0")))
      (IDIFFERENCE "N_OP_idifference($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER NIL
             (SUN3.N ("IDIFFERENCE_N_$pc($(Tos-1))" "movl a7@+,d0" "moveq #15,d2" "roll d2,d0" 
                            "subqb #7,d0" "bne $errorpc " "subl #$#(Tos<<15),d0 " "bvs $errorpc " 
                            "lsrl d2,d0" "orl #0x000E0000,d0")
                    SUN3
                    ("IDIFFERENCE_$pc($(Tos-1), $(Tos))" "movl a7@+,d0" "movl a7@+,d1" "moveq #15,d2"
                           "roll d2,d0" "subqb #7,d0" "bne $errorpc " "roll d2,d1" "subqb #7,d1" 
                           "bne $errorpc " "subl d1,d0 " "bvs $errorpc " "lsrl d2,d0" 
                           "orl #0x000E0000,d0")))
      (IDIFFERENCE.N "N_OP_idifferencen($(Tos), $x, $errorpc)" T 1 T NIL STR-PARSER NIL
             (SUN3 ("IDIFFERENCE_N_$pc($(Tos-1))" "movl a7@+,d0" "moveq #15,d2" "roll d2,d0" 
                          "subqb #7,d0" "bne $errorpc " "subl ##(n<<15),d0 " "bvs $errorpc " 
                          "lsrl d2,d0" "orl #0x000E0000,d0")))
      (PLUS2 "N_OP_plus2($(Tos-1), $(Tos), $errorpc) " T 2 T NIL STR-PARSER NIL
             (SUN3.N ("PLUS_N_$pc($(Tos-1))" "movl a7@+,d0" "moveq #15,d2" "roll d2,d0" "subqb #7,d0"
                            "bne $errorpc " "addl #$#(Tos<<15),d0 " "bvs $errorpc " "lsrl d2,d0" 
                            "orl #0x000E0000,d0")
                    SUN3
                    ("PLUS_$pc($(Tos-1), $(Tos))" "movl a7@+,d0" "movl a7@+,d1" "moveq #15,d2" 
                           "roll d2,d0" "subqb #7,d0" "bne $errorpc " "roll d2,d1" "subqb #7,d1" 
                           "bne $errorpc " "addl d1,d0 " "bvs $errorpc " "lsrl d2,d0" 
                           "orl #0x000E0000,d0")))
      (IPLUS2 "N_OP_iplus2($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER NIL
             (SUN3.N ("PLUS_N_$pc($(Tos-1))" "movl a7@+,d0" "moveq #15,d2" "roll d2,d0" "subqb #7,d0"
                            "bne $errorpc " "addl #$#(Tos<<15),d0 " "bvs $errorpc " "lsrl d2,d0" 
                            "orl #0x000E0000,d0")
                    SUN3
                    ("PLUS_$pc($(Tos-1), $(Tos))" "movl a7@+,d0" "movl a7@+,d1" "moveq #15,d2" 
                           "roll d2,d0" "subqb #7,d0" "bne $errorpc " "roll d2,d1" "subqb #7,d1" 
                           "bne $errorpc " "addl d1,d0 " "bvs $errorpc " "lsrl d2,d0" 
                           "orl #0x000E0000,d0")))
      (IPLUS.N "N_OP_iplusn($(Tos), $x, $errorpc)" T 1 T NIL STR-PARSER NIL
             (SUN3 ("I_N_$pc($(Tos-1))" "movl a7@+,d0" "moveq #15,d2" "roll d2,d0" "subqb #7,d0" 
                          "bne $errorpc " "addl #$#(n<<15),d0 " "bvs $errorpc " "lsrl d2,d0" 
                          "orl #0x000E0000,d0")))
      (QUOTIENT "N_OP_quot($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (IQUOTIENT "N_OP_iquot($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (TIMES2 "N_OP_times2($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (ITIMES2 "N_OP_itimes2($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (IREMAINDER "N_OP_iremainder($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (BOXIPLUS "N_OP_boxiplus($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (BOXIDIFFERENCE "N_OP_boxidifference($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (LOGAND2 "N_OP_logand($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER NIL
             (SUN3.N ("LOGAND_N_$pc($(Tos-1))" "movl a7@+,d0" "moveq #15,d2" "roll d2,d0" 
                            "cmpb #7,d0" "bne $errorpc " "andl #$#(Tos<<15) + 7,d0 " "rorl d2,d0")
                    SUN3
                    ("LOGAND_$pc($(Tos-1), $(Tos))" "movl a7@+,d0" "movl a7@+,d1" "moveq #15,d2" 
                           "roll d2,d0" "cmpb #7,d0" "bne $errorpc " "roll d2,d1" "cmpb #7,d1" 
                           "bne $errorpc " "andl d1,d0 " "rorl d2,d0")))
      (LOGOR2 "N_OP_logor($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER NIL
             (SUN3.N ("LOGOR_N_$pc($(Tos-1))" "movl a7@+,d0" "moveq #15,d2" "roll d2,d0" "cmpb #7,d0"
                            "bne $errorpc " "orl #$#(Tos<<15),d0 " "rorl d2,d0")
                    SUN3
                    ("LOGOR_$pc($(Tos-1), $(Tos))" "movl a7@+,d0" "movl a7@+,d1" "moveq #15,d2" 
                           "roll d2,d0" "cmpb #7,d0" "bne $errorpc " "roll d2,d1" "cmpb #7,d1" 
                           "bne $errorpc " "orl d1,d0 " "rorl d2,d0")))
      (LOGXOR2 "N_OP_logxor($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER NIL
             (SUN3.N ("LOGXOR_N_$pc($(Tos-1))" "movl a7@+,d0" "moveq #15,d2" "roll d2,d0" 
                            "cmpb #7,d0" "bne $errorpc " "eorl #$#(Tos<<15),d0 " "rorl d2,d0")
                    SUN3
                    ("LOGXOR_$pc($(Tos-1), $(Tos))" "movl a7@+,d0" "movl a7@+,d1" "moveq #15,d2" 
                           "roll d2,d0" "cmpb #7,d0" "bne $errorpc " "roll d2,d1" "subqb #7,d1" 
                           "bne $errorpc " "eorl d1,d0 " "rorl d2,d0")))

      (* |;;| "Shifts ")

      (LRSH8 "N_OP_lrsh8($(Tos), $errorpc)" T 1 T NIL STR-PARSER NIL
             (SUN3 ("LRSH8_$pc($(Tos))" "movl a7@+,d0" "movl d0,d1" "swap d1" "cmpw #0xe,d1" 
                          "bne $errorpc " "lsrw #8,d0")))
      (LRSH1 "N_OP_lrsh1($(Tos), $errorpc)" T 1 T NIL STR-PARSER NIL
             (SUN3 ("LRSH1_$pc($(Tos))" "movl a7@+,d0" "movl d0,d1" "swap d1" "bne $errorpc " 
                          "lsrw #1,d0")))
      (LLSH8 "N_OP_llsh8($(Tos), $errorpc)" T 1 T NIL STR-PARSER NIL
             (SUN3 ("LLSH8_$pc($(Tos))" "movl a7@+,d0" "movl d0,d1" "swap d1" "cmpw #0xE,d1" 
                          "bne $errorpc " "cmpw #0x0ff,d0" "bhi $errorpc " "lslw #8,d0")))
      (LLSH1 "N_OP_llsh1($(Tos), $errorpc)" T 1 T NIL STR-PARSER NIL
             (SUN3 ("LLSH1_$pc($(Tos))" "movl a7@+,d0" "movl d0,d1" "swap d1" "cmpw #0xE,d1" 
                          "bne $errorpc " "lslw #1,d0" "bcs $errorpc ")))
      (LSH "N_OP_lsh($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)

      (* |;;| "Constants")

      (\'0 "$0" NIL 0 T T CONST-PARSER)
      (\'1 "$1" NIL 0 T T CONST-PARSER)
      (\'NIL "NIL_PTR" NIL 0 T T STR-PARSER)
      (\'T "ATOM_T" NIL 0 T T STR-PARSER)
      (SIC "$x" NIL 0 T T CONST-PARSER)
      (SNIC "$-x" NIL 0 T T CONST-PARSER)
      (SICX "$x16" NIL 0 T T CONST-PARSER)
      (ACONST "$a16" NIL 0 T T STR-PARSER)
      (GCONST "$g24" NIL 0 T T STR-PARSER)

      (* |;;| "Conditionals")

      (GREATERP "(N_OP_greaterp($(Tos-1), $(Tos), $errorpc))" T 2 T NIL STR-PARSER NIL
             (SUN3.N ("GREATERP_N_$pc($(Tos-1))" "movl a7@+,d1" "moveq #15,d2" "roll d2,d1" 
                            "subqb #7,d1" "bne $errorpc " "clrl d0" "cmpl #$#(Tos<<15),d1 " 
                            "ble gt_lab$pc" "moveq #76,d0" "gt_lab$pc: ")
                    SUN3
                    ("GREATERP_$pc($(Tos-1), $(Tos))" "movl a7@+,d3" "movl a7@+,d1" "moveq #15,d2" 
                           "roll d2,d1" "subqb #7,d1" "bne $errorpc " "roll d2,d3" "subqb #7,d3" 
                           "bne $errorpc " "clrl d0" "cmpl d1,d3 " "ble gt_lab$pc" "moveq #76,d0" 
                           "gt_lab$pc: ")))
      (IGREATERP "(N_OP_igreaterp($(Tos-1), $(Tos), $errorpc))" T 2 T T STR-PARSER NIL
             (SUN3.N ("IGREATERP_N_$pc($(Tos-1))" "movl a7@+,d1" "moveq #15,d2" "roll d2,d1" 
                            "subqb #7,d1" "bne $errorpc " "clrl d0" "cmpl #$#(Tos<<15),d1 " 
                            "ble igt_lab$pc" "moveq #76,d0" "igt_lab$pc: ")
                    SUN3
                    ("IGREATERP_$pc($(Tos-1), $(Tos))" "movl a7@+,d3" "movl a7@+,d1" "moveq #15,d2" 
                           "roll d2,d1" "subqb #7,d1" "bne $errorpc " "roll d2,d3" "subqb #7,d3" 
                           "bne $errorpc " "clrl d0" "cmpl d1,d3 " "ble igt_lab$pc" "moveq #76,d0" 
                           "igt_lab$pc: ")))
      (EQ "($(C2Tos) == $(Tos-1))" NIL 2 NIL T STR-PARSER)
      (EQL "(N_OP_eqlop($(Tos-1), $(Tos), $errorpc))" T 2 T NIL STR-PARSER)

      (* |;;| "Type opcodes")

      (INSTANCEP "(N_OP_instancep($(Tos), $x16))" NIL 1 T NIL STR-PARSER)
      (TYPEMASK.N "N_OP_TYPEMASK($x<<8)" T 1 NIL NIL STR-PARSER)
      (DTEST "(N_OP_dtest($(Tos), $x16, $errorpc))" T 1 T NIL STR-PARSER)
      (TYPECHECK "(N_OP_dtest($(Tos), $x16, $errorpc))" T 1 T NIL STR-PARSER)
      (TYPEP "((DLword)GetTypeNumber($(C3Tos)) == $x)" NIL 1 T NIL COND-PARSER)
      (NTYPX " (S_POSITIVE | (unsigned int)GetTypeNumber($(Tos)))" T 1 T T STR-PARSER)
      (LISTP "((DLword)GetTypeNumber($(C3Tos)) == TYPE_LISTP)" NIL 1 T NIL COND-PARSER)

      (* |;;| "Jumps")

      (TJUMP "if ($(Tos)) { goto pc$jt; }" NIL 1 NIL NIL JUMP-PARSER)
      (FJUMP "if (!($(Tos))) { goto pc$jt; }" NIL 1 NIL NIL JUMP-PARSER)
      (TJUMPX "if ($(Tos)) { goto pc$jt; }" NIL 1 NIL NIL JUMP-PARSER)
      (FJUMPX "if (!($(Tos))) { goto pc$jt; }" NIL 1 NIL NIL JUMP-PARSER)
      (NFJUMPX "if (!($Tos)) { goto pc$jt; } else POP" NIL 1 NIL NIL JUMP-PARSER)
      (NTJUMPX "if ($Tos) { goto pc$jt; } else POP" NIL 1 NIL NIL JUMP-PARSER)
      (JUMP "goto pc$jt " T 0 NIL NIL JUMP-PARSER)
      (JUMPX "goto pc$jt " T 0 NIL NIL JUMP-PARSER)
      (JUMPXX "goto pc$jt " T 0 NIL NIL JUMP-PARSER)
      (-X- "{}" NIL NIL NIL NIL STR-PARSER)
      (NOP "{}" NIL NIL NIL NIL STR-PARSER)

      (* |;;| "Function call & return")

      (FN0 "fncall_$who(0, $fn-call-args)" T 0 T NIL FN-CALL-PARSER)
      (FN1 "fncall_$who(1, $fn-call-args)" T 1 T NIL FN-CALL-PARSER)
      (FN2 "fncall_$who(2, $fn-call-args)" T 2 T NIL FN-CALL-PARSER)
      (FN3 "fncall_$who(3, $fn-call-args)" T 3 T NIL FN-CALL-PARSER)
      (FN4 "fncall_$who(4, $fn-call-args)" T 4 T NIL FN-CALL-PARSER)
      (FNX "fncall_$who($x, $fn-call-args)" T 3 T NIL FN-CALL-PARSERX)
      (RETURN "IVAR[0] = $(Tos); return_op($bce-pc, $swapped-fn-obj)" T 1 NIL NIL STR-PARSER)
      (APPLYFN "RETURN_TO_FN_CALL($bce-pc, ret_to_apply)" T 2 NIL NIL STR-PARSER)
      (ENVCALL "RETURN_TO_FN_CALL($bce-pc, ret_to_envcall)" T 3 T NIL ENVCALL-PARSER)
      (CHECKAPPLY* "N_OP_CHECKAPPLY($Tos, $bce-pc)" T 1 NIL NIL STR-PARSER)

      (* |;;| "Pointer Operations")

      (GETBASEPTR.N " GETBASEPTR_N($(Tos),$x)" NIL 1 T T STR-PARSER NIL NIL)
      (ADDBASE "BCE($bce-pc, $op)" T 2 T NIL STR-PARSER NIL
             (SUN3.N ("ADDBASE_N_$pc($(Tos-1))" "movl a7@+,d0" "andl #0xFFFFFF,d0" 
                            "addl #$#(Tos),d0 ")
                    SUN3
                    ("ADDBASE_$pc($(Tos-1), $(Tos))" "movl a7@+,d0" "movl a7@+,d1" "moveq #15,d2" 
                           "roll d2,d1" "subqb #7,d1" "bne $errorpc " "asrl d2,d1" 
                           "andl #0xFFFFFF,d0" "addl d1,d0 ")))
      (GETBASE.N " GETBASE_N($(Tos),$x)" NIL 1 T T STR-PARSER NIL NIL)
      (PUTBASE.N "N_OP_putbasen($(Tos-1), $(Tos), $x, $errorpc)" T 2 T NIL STR-PARSER)
      (PUTBASEPTR.N "N_OP_putbaseptrn($(Tos-1), $(Tos), $x, $errorpc)" T 2 T NIL STR-PARSER NIL NIL)
      (PUTBITS.N.FD "N_OP_putbitsnfd($(Tos-1), $(Tos), $x, $x2, $errorpc)" T 2 T NIL STR-PARSER NIL 
             NIL)
      (GETBITS.N.FD "N_OP_getbitsnfd($(Tos), $x, $x2)" T 2 T NIL STR-PARSER)
      (GETBASEBYTE "N_OP_getbasebyte($(Tos-1), $(Tos),$errorpc)" T 2 T NIL STR-PARSER)
      (PUTBASEBYTE "N_OP_putbasebyte($(Tos-2), $(Tos-1), $(Tos),$errorpc)" T 3 T NIL STR-PARSER)
      (RPLPTR.N "N_OP_rplptr($(Tos-1), $(Tos), $x)" NIL 2 T NIL STR-PARSER)
      (ATOMCELL.N "N_OP_atomcellN($(Tos), $x, $errorpc)" T 1 T NIL STR-PARSER)
      (VAG2 "*** need asm code error****" NIL 2 T NIL STR-PARSER NIL
            (SUN3 ("VAG2_$pc($(Tos-1), $(Tos))" "movl a7@+,d0" "movl a7@+,d1" "swap d0" "clrw d0" 
                         "movw d1,d0")))
      (HILOC "( S_POSITIVE | (((unsigned int) $(Tos)) >> 16) )" NIL 1 T T STR-PARSER)
      (LOLOC "( S_POSITIVE | (((unsigned int) $(Tos)) & 0xffff) )" NIL 1 T T STR-PARSER)

      (* |;;| "List Operations")

      (CAR "N_OP_CAR($(Tos), $error-label)" T 2 T NIL STR-PARSER)
      (CDR "N_OP_cdr($(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (CONS " N_OP_cons($(Tos-1), $(Tos))" NIL 2 T NIL STR-PARSER)
      (RPLCONS "N_OP_rplcons($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (RPLACA "N_OP_rplaca($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (RPLACD "N_OP_rplacd($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (FMEMB "N_OP_fmemb($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (LISTGET "N_OP_listget($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (ASSOC "N_OP_assoc($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (CMLASSOC "N_OP_classoc($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (CMLMEMBER "N_OP_clfmemb($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)

      (* |;;| "Array Opcodes")

      (AREF1 "N_OP_aref1($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (AREF2 "N_OP_aref2($(Tos-2), $(Tos-1), $(Tos), $errorpc)" T 3 T NIL STR-PARSER)
      (ASET1 "N_OP_aset1($(Tos-2), $(Tos-1), $(Tos), $errorpc)" T 3 T NIL STR-PARSER)
      (ASET2 "N_OP_aset2($(Tos-3), $(Tos-2), $(Tos-1), $(Tos), $errorpc)" T 4 T NIL STR-PARSER)

      (* |;;| "Other Opcodes")

      (DRAWLINE "N_OP_drawline($(Tos-8), $(Tos-7), $(Tos-6), $(Tos-5), $(Tos-4), $(Tos-3), $(Tos-2), $(Tos-1), $(Tos), $errorpc)"
             T 2 T NIL STR-PARSER)
      (BLT "N_OP_blt($(Tos-2), $(Tos-1), $(Tos), $errorpc)" T 3 T NIL STR-PARSER)
      (MAKENUMBER "N_OP_makenumber($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (BIN "N_OP_bin($(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (RCLK "N_OP_rclk($(Tos))" T 1 T NIL STR-PARSER)
      (CREATECELL "N_OP_createcell($(Tos), $errorpc)" T 1 T NIL STR-PARSER)
      (PILOTBITBLT "N_OP_pilotbitblt($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)

      (* |;;| "Misc Opcodes")

      (MISC1 NIL T 1 NIL NIL BCE-PARSER)
      (MISC2 NIL T 2 NIL NIL BCE-PARSER)
      (MISC3 "PUSH(N_OP_misc3($(Tos-2), $(Tos-1), $(Tos), $x,  $errorpc))" T 3 T NIL STR-PARSER)
      (MISC4 "PUSH(N_OP_misc4($(Tos-3), $(Tos-2), $(Tos-1), $(Tos), $x,  $errorpc))" T 4 T NIL 
             STR-PARSER)
      (MISC7 NIL T 7 NIL NIL BCE-PARSER)
      (MISC8 NIL T 8 NIL NIL BCE-PARSER)
      (MISC10 NIL T 10 NIL NIL BCE-PARSER)
      (UBFLOAT3 "CALL_OP_FN($bce-pc, $next-bce-pc, OP_ubfloat3)" T 3 NIL NIL STR-PARSER)
      (RECLAIMCELL "CALL_OP_FN($bce-pc, $next-bce-pc, OP_reclaimcell)" T 2 T NIL STR-PARSER)
      (GCSCAN1 "CALL_OP_FN($bce-pc, $next-bce-pc, OP_gcscan1)" T 2 T NIL STR-PARSER)
      (GCSCAN2 "CALL_OP_FN($bce-pc, $next-bce-pc, OP_gcscan2)" T 1 T NIL STR-PARSER)
      (GCREF "CALL_OP_FN($bce-pc, $next-bce-pc, OP_gcref)" T 1 T NIL STR-PARSER)
      (FQUOTIENT "N_OP_fquotient($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (FTIMES2 "N_OP_ftimes2($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (FDIFFERENCE "N_OP_fdifference($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (FPLUS2 "N_OP_fplus2($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (FGREATERP "N_OP_fgreaterp($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (EQUAL "N_OP_equal($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (CMLEQUAL "N_OP_clequal($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (= "N_OP_eqq($(Tos-1), $(Tos), $errorpc)" T 2 T NIL STR-PARSER)
      (SUBRCALL "CALL_OP_FN($bce-pc, $next-bce-pc, OP_subrcall)" T 0 NIL NIL STR-PARSER)

      (* |;;| "Unimplemented Opcodes")

      (BUSBLT NIL T 0 NIL NIL BCE-PARSER)
      (RDPROLOGPTR NIL T 0 NIL NIL BCE-PARSER)
      (RDPROLOGTAG NIL T 0 NIL NIL BCE-PARSER)
      (WRTPTR&TAG NIL T 0 NIL NIL BCE-PARSER)
      (WRTPTR&0TAG NIL T 0 NIL NIL BCE-PARSER)
      (DOVEMISC NIL T 0 NIL NIL BCE-PARSER)
      (RAID NIL T 0 NIL NIL BCE-PARSER)
      (\\RETURN NIL T 0 NIL NIL BCE-PARSER)
      (READFLAGS NIL T 0 NIL NIL BCE-PARSER)
      (READRP NIL T 0 NIL NIL BCE-PARSER)
      (WRITEMAP NIL T 0 NIL NIL BCE-PARSER)
      (READPRINTERPORT NIL T 0 NIL NIL BCE-PARSER)
      (WRITEPRINTERPORT NIL T 0 NIL NIL BCE-PARSER)
      (RETCALL NIL T 0 NIL NIL BCE-PARSER)
      (FLOATBLT NIL T 0 NIL NIL BCE-PARSER)
      (FFTSTEP NIL T 0 NIL NIL BCE-PARSER)
      (UPCTRACE NIL T 0 NIL NIL BCE-PARSER)
      (UBFLOAT1 NIL T 1 NIL NIL BCE-PARSER)
      (UBFLOAT2 NIL T 2 NIL NIL BCE-PARSER)
      (POPDISP NIL T 2 T NIL BCE-PARSER)
      (RESTLIST NIL T 2 T NIL BCE-PARSER)
      (CONTEXTSWITCH NIL T 2 T NIL BCE-PARSER)
      (EVAL NIL T 2 T NIL BCE-PARSER)
      (P-MISC2 NIL T 2 T NIL BCE-PARSER)
      (BOUT NIL T 2 T NIL BCE-PARSER)
      (BASE-< NIL T 2 T NIL BCE-PARSER))))

(MAKE-ORDERING-LIST
  (LAMBDA NIL                                            (* \; "Edited 24-Jun-88 16:37 by rtk")
    `(("$CSTKPTR" CSTKPTR ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                               'CSTKPTR))
      ("$Tos" TOS ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                       (TOS-CHECK TRANS-REC BYTE-REC PATTERN-LIST)))
      ("$(Tos)" POP ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                         'POP)
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK*))
                  (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO))
                  REPLACEMENT-VALUE))
      ("$(C2Tos)" POP ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                           'POP)
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK* *ADD-HEAD* *ADD-TAIL*))
                  (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO))
                  (COND
                     ((NEQ (|fetch| (BYTE-INFO-REC LEVEL-ADJUST) |of| (|fetch|
                                                                               (BYTE-INFO-REC 
                                                                                      NEXT-BYTE-REC)
                                                                                 |of| BYTE-REC))
                           'CJUMP)
                      (SETQ *ADD-HEAD* "(")
                      (SETQ *ADD-TAIL* " ? ATOM_T : NIL_PTR)"))
                     (T NIL))
                  REPLACEMENT-VALUE))
      ("$(C3Tos)" POP ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                           (COND
                              ((EQ (|fetch| (BYTE-INFO-REC LEVEL-ADJUST)
                                      |of| (|fetch| (BYTE-INFO-REC NEXT-BYTE-REC)
                                                  |of| BYTE-REC))
                                   'CJUMP)
                               'POP)
                              (T (PUSH-ALL-OPERANDS)
                                 'TOS)))
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK* *ADD-HEAD* *ADD-TAIL*))
                  (COND
                     ((EQ (|fetch| (BYTE-INFO-REC LEVEL-ADJUST) |of| (|fetch|
                                                                              (BYTE-INFO-REC 
                                                                                     NEXT-BYTE-REC)
                                                                                |of| BYTE-REC))
                          'CJUMP)
                      (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO)))
                     (T (SETQ *ADD-HEAD* "	if (!")
                        (SETQ *ADD-TAIL* ") TOS = NIL_PTR;")))
                  REPLACEMENT-VALUE))
      ("$#(Tos)" TOS-IMM ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                              (CL:MULTIPLE-VALUE-BIND (TOS-VAL TOS-INFO)
                                     (OPERAND-POP T)
                                     (SETQ *TOS-INFO* TOS-INFO)
                                     (SETQ *TOS-VAL* TOS-VAL)
                                     TOS-VAL)))
      ("$#(Tos<<15)" TOS<<15 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                                  (CL:MULTIPLE-VALUE-BIND (TOS-VAL TOS-INFO)
                                         (OPERAND-POP T)
                                         (SETQ *TOS-INFO* TOS-INFO)
                                         (SETQ *TOS-VAL* TOS-VAL)
                                         (|push| *ERROR-STACK* (GET-VAL TOS-VAL TOS-INFO))
                                         TOS-VAL))
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK*))
                  (GET-SHIFTED-VAL REPLACEMENT-VALUE 15)))
      ("$(Tos-1)" POP-1 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                             'POP)
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK*))
                  (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO))
                  REPLACEMENT-VALUE))
      ("$(Tos-2)" POP-2 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                             'POP)
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK*))
                  (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO))
                  REPLACEMENT-VALUE))
      ("$(Tos-3)" POP-3 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                             'POP)
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK*))
                  (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO))
                  REPLACEMENT-VALUE))
      ("$(Tos-4)" POP-4 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                             'POP)
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK*))
                  (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO))
                  REPLACEMENT-VALUE))
      ("$(Tos-5)" POP-5 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                             'POP)
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK*))
                  (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO))
                  REPLACEMENT-VALUE))
      ("$(Tos-6)" POP-6 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                             'POP)
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK*))
                  (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO))
                  REPLACEMENT-VALUE))
      ("$(Tos-7)" POP-7 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                             'POP)
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK*))
                  (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO))
                  REPLACEMENT-VALUE))
      ("$(Tos-8)" POP-8 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                             'POP)
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (SPECIAL *ERROR-STACK*))
                  (|push| *ERROR-STACK* (GET-VAL REPLACEMENT-VALUE STR-INFO))
                  REPLACEMENT-VALUE))
      ("$op<3><<1" OP<3><<1 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                                 (LLSH (LOGAND (|fetch| (BYTE-INFO-REC OPCODE) |of| BYTE-REC)
                                              7)
                                       1)))
      ("$op<3>" OP<3> ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                           (LOGAND (|fetch| (BYTE-INFO-REC OPCODE) |of| BYTE-REC)
                                  7)))
      ("$op" OP ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                     (|fetch| (BYTE-INFO-REC OPCODE) |of| BYTE-REC)))
      ("$x/2" X/2 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                       (LRSH (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)
                             1)))
      ("$x2" X2 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                     (|fetch| (BYTE-INFO-REC ARG2) |of| BYTE-REC)))
      ("$x16<<1" X16<<1 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                             (LLSH (LOGOR (LLSH (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)
                                                8)
                                          (|fetch| (BYTE-INFO-REC ARG2) |of| BYTE-REC))
                                   1)))
      ("$x<<8" X<<8 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                         (LLSH (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)
                               8)))
      ("$x16" X16 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                       (LOGOR (LLSH (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)
                                    8)
                              (|fetch| (BYTE-INFO-REC ARG2) |of| BYTE-REC))))
      ("$-x" -X ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                     (MINUS (ADD1 (LOGXOR (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)
                                         255)))))
      ("$x" X ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                   (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)))
      ("$a16" SYMBOL-INDEX ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                                (SET-INFO 'INFO-TYPE 'ACONST)
                                (LOGOR (LLSH (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)
                                             8)
                                       (|fetch| (BYTE-INFO-REC ARG2) |of| BYTE-REC))))
      ("$g24" GCONST-PTR ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                              (SET-INFO 'INFO-TYPE 'GCONST)
                              (LOGOR (LLSH (|fetch| (BYTE-INFO-REC ARG1) |of| BYTE-REC)
                                           16)
                                     (LLSH (|fetch| (BYTE-INFO-REC ARG2) |of| BYTE-REC)
                                           8)
                                     (|fetch| (BYTE-INFO-REC ARG3) |of| BYTE-REC))))
      ("$jt" JUMP-TARGET ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                              (|fetch| (BYTE-INFO-REC JUMP-TO-ADDRESS) |of| BYTE-REC)))
      ("$swapped-fn-obj" SWAPPED-FN-OBJECT ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                                                (DECLARE (SPECIAL *CODE-BASE*))
                                                (SWAPPED-FN-OBJ *CODE-BASE*)))
      ("$pc" PC ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                     (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC)))
      ("$bce-pc" BCE-PC ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                             (DECLARE (CL:SPECIAL *CODE-BASE*))
                             (BCE-PC (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC)
                                    *CODE-BASE*)))
      ("$next-bce-pc" NEXT-BCE-PC ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                                       (DECLARE (CL:SPECIAL *CODE-BASE*))
                                       (+ (|fetch| (BYTE-INFO-REC OPLENGTH) |of| BYTE-REC)
                                          (BCE-PC (|fetch| (BYTE-INFO-REC PC) |of| 
                                                                                            BYTE-REC)
                                                 *CODE-BASE* T)
                                          1)))
      ("$errorpc" ERRORPC ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                               (CONCAT "errorpc" (|fetch| (BYTE-INFO-REC PC) |of| BYTE-REC)))
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (CL:SPECIAL *ERROR-PC*))
                  (SETQ *ERROR-PC* T)
                  REPLACEMENT-VALUE))
      ("$error-label" ERRORPC ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                                   (CONCAT "errorpc" (|fetch| (BYTE-INFO-REC PC) |of| 
                                                                                           BYTE-REC))
                                   )
             ,#'(LAMBDA (TRANS-REC BYTE-REC PARAMETER REPLACEMENT-VALUE STR-INFO)
                  (DECLARE (CL:SPECIAL *ERROR-PC* *ARG-COUNT*))
                  (SETQ *ERROR-PC* T)
                  (SETQ *ARG-COUNT* 0)
                  REPLACEMENT-VALUE))
      ("$who" WHO-CALLED ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                              (DECLARE (CL:SPECIAL *CALL-SELF*))
                              (|if| *CALL-SELF*
                                  |then| "self"
                                |else| "other")))
      ("$fn-call-args" FN-CALL-ARGS ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                                         (DECLARE (CL:SPECIAL *FN-CALL-STR*))
                                         *FN-CALL-STR*))
      ("$0" \'0 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                     0))
      ("$1" \'1 ,#'(LAMBDA (TRANS-REC BYTE-REC PATTERN-LIST)
                     1)))))
)



(* |;;| "Opcode Verification Fns")

(DEFINEQ

(VERIFY-OPCODES
  (LAMBDA NIL                                            (* \; "Edited 31-May-88 18:01 by rtk")
    (LET (*TRANSLATION-TABLE* *BYTE-INFO-TABLE* (*CODE-SIZE* 0))
         (DECLARE (SPECVARS *TRANSLATION-TABLE* *CODE-SIZE* *BYTE-INFO-TABLE*))
         (TRANSLATION-INIT T)
         (|for| |opcode| |in| \\OPCODES |do| (VERIFY-OPCODE (|fetch| (OP#)
                                                                               |of| |opcode|)
                                                                |opcode|)))))

(VERIFY-OPCODE
  (LAMBDA (|opcode| |opcode-rec|)                        (* \; "Edited 13-Apr-88 15:54 by rtk")
    (COND
       ((LISTP |opcode|)
        (|for| |ops| |from| (CAR |opcode|) |to| (CADR |opcode|)
           |do| (VERIFY-OPCODE |ops| |opcode-rec|)))
       (T (|if| (NOT (ELT *TRANSLATION-TABLE* |opcode|))
              |then| (|if| (AND (NULL (STRPOS "was" (|fetch| (OPCODENAME) |of| 
                                                                                         |opcode-rec|
                                                                   )))
                                        (NULL (STRPOS "unused" (|fetch| (OPCODENAME) |of|
                                                                                         |opcode-rec|
                                                                      ))))
                             |then| (PRINTOUT T "Opcode: " (|fetch| (OPCODENAME) |of|
                                                                                         |opcode-rec|
                                                                      )
                                               " Missing: "
                                               (|fetch| (OP#) |of| |opcode-rec|)
                                               T)))))))
)



(* |;;| "New Code Block Fns")

(DEFINEQ

(LOADNATIVE
  (LAMBDA (|f-name| |file-name| ENTRY-PT-NAME |fn-obj| OLD-FN-OBJECT)
                                                             (* \; "Edited 21-Jun-88 18:07 by rtk")
    (PRINTOUT *NATIVE-STREAM* "Compile to Native: " |fn| " File: " |file-name| T)
    (LET* ((|full-file-name-no-brackets| (CONCAT IL:*NATIVE-TEMP-FILE-DIRECTORY* "/" |file-name|))
           (|lisp-full-file-name| (CONCAT "{UNIX}" |full-file-name-no-brackets|))
           (|lisp-full-file-name.o| (CONCAT |lisp-full-file-name| ".o"))
           |relocatable-stream| |file-size| (|native-code-block-ptr| 0)
           (|native-code-addr| 0)
           |hex-load-addr| |load-request-result| (|load-file-size| 0)
           (NATIVE-ENTRY-PT-ADDR 0))
          (AND (|if| (EQ (MACHINETYPE)
                             'MAIKO)
                   |then| (AND 
                                   (* |;;| "Execute the Unix C Compiler ")

                                   (DO-EXEC-COMMAND (CL:FORMAT NIL 
                                            "~a/cc -c -pipe -O ~a.c -o ~a.o ~a.il ~a/disp68K.il -I~a"
                                                               IL:*NATIVE-BIN-DIRECTORY* 
                                                               |full-file-name-no-brackets| 
                                                               |full-file-name-no-brackets| 
                                                               |full-file-name-no-brackets| 
                                                               IL:*NATIVE-INCLUDE-FILE-DIRECTORY* 
                                                               IL:*NATIVE-INCLUDE-FILE-DIRECTORY*))

                                   (* |;;| "Remove the Temp Files")

                                   (OR *KEEP-NATIVE-SOURCES* (AND *REMOVE-TEMP-NATIVE-FILES*
                                                                  (DO-EXEC-COMMAND (CL:FORMAT
                                                                                        NIL 
                                                                                      "rm ~a.c ~a.il"
                                                                                        
                                                                         |full-file-name-no-brackets|
                                                                                        
                                                                         |full-file-name-no-brackets|
                                                                                        )))
                                       T)

                                   (* |;;| "Get the Object File SIze")

                                   (SETQ |file-size| (GET-NATIVE-LOAD-SIZE 
                                                            |lisp-full-file-name.o|))

                                   (* |;;| "Allocate a block big enough to hold the object")

                                   (SETQ |native-code-block-ptr| (\\ALLOCBLOCK (FOLDHI |file-size| 
                                                                                      BYTESPERCELL)
                                                                        UNBOXEDBLOCK.GCT CELLSPERQUAD
                                                                        CELLSPERQUAD))
                                   (SETQ |native-code-addr| (LISP-ADDR-TO-NATIVE-ADDR 
                                                                   |native-code-block-ptr|))

                                   (* |;;| "Execute the Unix Linker")
                                                             (* DO-EXEC-COMMAND
                                                           (CL:FORMAT NIL 
                                                "~a/ld -N -s -e _~a -Ttext ~x -A ~a ~a.o -o ~a -lc"
                                 IL:*NATIVE-BIN-DIRECTORY* ENTRY-PT-NAME |native-code-addr| 
                                                           IL:*NATIVE-LISP-RUN-FILENAME* 
                                                           |full-file-name-no-brackets| 
                                                           |full-file-name-no-brackets|))
                                   (DO-EXEC-COMMAND (CL:FORMAT NIL 
                                                         "~a/ld -N -s -Ttext ~x -A ~a ~a.o -o ~a -lc"
                                                               IL:*NATIVE-BIN-DIRECTORY* 
                                                               |native-code-addr| 
                                                               IL:*NATIVE-LISP-RUN-FILENAME* 
                                                               |full-file-name-no-brackets| 
                                                               |full-file-name-no-brackets|))
                                   (PROGN (PRINTOUT *NATIVE-STREAM* "Load " |file-name| " At " 
                                                 |native-code-addr| " for " |file-size| " bytes." T)
                                          T)

                                   (* |;;| "Remove the Temp .o File")

                                   (OR (AND *REMOVE-TEMP-NATIVE-FILES* (DO-EXEC-COMMAND
                                                                        (CL:FORMAT NIL "rm ~a.o" 
                                                                         |full-file-name-no-brackets|
                                                                               )))
                                       T)

                                   (* |;;| "Load the code into lisp space")

                                   (SETQ NATIVE-ENTRY-PT-ADDR (LOAD-NATIVE-FILE 
                                                                     |lisp-full-file-name| 
                                                                     |native-code-block-ptr| NIL))

                                   (* |;;| "Remove the Temp File")

                                   (OR (AND *REMOVE-TEMP-NATIVE-FILES* (DO-EXEC-COMMAND
                                                                        (CL:FORMAT NIL "rm ~a" 
                                                                         |full-file-name-no-brackets|
                                                                               )))
                                       T))
                 |else| 

                       (* |;;| "Allocate a dummy block if not maiko")

                       (SETQ |native-code-block-ptr| (\\ALLOCBLOCK (FOLDHI *CODE-SIZE* BYTESPERCELL)
                                                            UNBOXEDBLOCK.GCT CELLSPERQUAD 
                                                            CELLSPERQUAD)))

               (* |;;| "Set Native Adder in Fn Object")

               (SET-NATIVE-ADDR |f-name| |fn-obj| |native-code-block-ptr| NATIVE-ENTRY-PT-ADDR)

               (* |;;| "Add the New GCONST  xx POP opcodes")

               (ADD-GCONST |fn-obj| 0 |native-code-block-ptr|)
               (ADD-GCONST |fn-obj| 6 OLD-FN-OBJECT)

               (* |;;| "Set the New Function Definition")

               (SET-NEW-FUNCTION-DEF |f-name| |fn-obj| *NATIVE-STREAM*)
               |fn-obj|))))

(GET-NATIVE-LOAD-SIZE
  (LAMBDA (FILE-NAME)                                    (* \; "Edited 17-Jun-88 17:00 by rtk")

    (* |;;| "Return the Size of Block needed for the Native Code Object")

    (LET ((FN-HEADER-INFO (CREATE NATIVE-LINKER-INFO))
          FILE-STREAM)
         (AND (SETQ FILE-STREAM (OPENSTREAM FILE-NAME 'INPUT))
              (\\BINS FILE-STREAM FN-HEADER-INFO 0 (FETCH (NATIVE-LINKER-INFO RECORD-SIZE)
                                                      OF FN-HEADER-INFO))
              (CLOSEF FILE-STREAM)
              (IPLUS (FETCH (NATIVE-LINKER-INFO DATA-SIZE) OF FN-HEADER-INFO)
                     (FETCH (NATIVE-LINKER-INFO TEXT-SIZE) OF FN-HEADER-INFO)
                     (FETCH (NATIVE-LINKER-INFO BSS-SIZE) OF FN-HEADER-INFO))))))

(LOAD-NATIVE-FILE
  (LAMBDA (FILE-NAME LOAD-PTR INITIAL-BYTES)             (* \; "Edited 17-Jun-88 17:24 by rtk")
    (LET ((FN-HEADER-INFO (CREATE NATIVE-LINKER-INFO))
          FILE-STREAM LOAD-SIZE)
         (AND (SETQ FILE-STREAM (OPENSTREAM FILE-NAME 'INPUT))
              (\\BINS FILE-STREAM FN-HEADER-INFO 0 (FETCH (NATIVE-LINKER-INFO RECORD-SIZE)
                                                      OF FN-HEADER-INFO))
              (SETQ LOAD-SIZE (IPLUS (FETCH (NATIVE-LINKER-INFO DATA-SIZE) OF FN-HEADER-INFO)
                                     (FETCH (NATIVE-LINKER-INFO TEXT-SIZE) OF FN-HEADER-INFO)
                                     ))
              (PROGN (PRINTOUT *NATIVE-STREAM* "Load: " FILE-NAME " at " LOAD-PTR " for " LOAD-SIZE 
                            " Entry PT: " (FETCH (NATIVE-LINKER-INFO ENTRY-POINT) OF 
                                                                                       FN-HEADER-INFO
                                                 )
                            T)
                     T)
              (\\BINS FILE-STREAM LOAD-PTR (LENGTH INITIAL-BYTES)
                     LOAD-SIZE)
              (CLOSEF FILE-STREAM)

              (* |;;| "Add in intiial code")

              (PROGN (IF INITIAL-BYTES
                         THEN 

                               (* |;;| "Add the ENTRY - PT to end of INTIIAL BYTES")

                               (SETQ INITIAL-BYTES (APPEND INITIAL-BYTES (UNPACK-NUMBER
                                                                          (FETCH (
                                                                                   NATIVE-LINKER-INFO
                                                                                      ENTRY-POINT)
                                                                             OF FN-HEADER-INFO)
                                                                          4)))
                               (FOR OFFSET FROM 0 TO (SUB1 (LENGTH INITIAL-BYTES))
                                  AS VALUE IN INITIAL-BYTES
                                  DO (\\PUTBASEBYTE LOAD-PTR OFFSET VALUE)))
                     T)
              (FETCH (NATIVE-LINKER-INFO ENTRY-POINT) OF FN-HEADER-INFO)))))

(SET-CODE-BASE
  (LAMBDA (FN)                                       (* \; "Edited 19-Apr-88 15:51 by Krivacic")

    (* |;;| "Set the Code Base")

    (|if| (\\CODEBLOCKP FN)
        |then| FN
      |else| (OR (CCODEP FN)
                     (ERROR FN "not compiled code"))
            (\\GET-COMPILED-CODE-BASE FN))))

(MAKE-NEW-CODE-BLOCK
  (LAMBDA (FN PC-OFFSET NEW-STKMIN GCONST-OFFSET)        (* \; "Edited  9-Jun-88 12:16 by rtk")

(* |;;;| "Mske a new code block for the function, moving the code 32 bits down to leave a slot for the address fo the Native Code.  Return the pointer to the new code object.")

    (DECLARE (SPECIAL *CODE-SIZE* *START-PC* *FN-NAME* *CODE-BASE* *GCONST-PTRS*))

    (* |;;| "Save Code Base")

    (SETQ *CODE-BASE* (CODE-BLOCK-COPY *CODE-BASE* *START-PC* *CODE-SIZE* 0 (+ *START-PC* 
                                                                                   PC-OFFSET)
                             GCONST-OFFSET *GCONST-PTRS* NIL))
    (|replace| (FNHEADER STKMIN) |of| *CODE-BASE* |with| NEW-STKMIN)

    (* |;;| "Fixup the Global Values")

    (SETQ *START-PC* (+ *START-PC* PC-OFFSET))
    (SETQ *CODE-SIZE* (+ *CODE-SIZE* PC-OFFSET GCONST-OFFSET))))

(SET-NEW-FUNCTION-DEF
  (LAMBDA (FN FN-OBJ STREAM)                             (* \; "Edited  1-Jun-88 12:22 by rtk")
    (PRINTOUT STREAM "Redefining " FN T)
    (COND
       ((\\CODEBLOCKP FN)
        NIL)
       ((LITATOM FN)
        (PUTD FN (|create| COMPILED-CLOSURE
                        FNHEADER _ FN-OBJ)))
       ((AND (EQ (NTYPX FN)
                 \\COMPILED-CLOSURE))
        (|replace| (COMPILED-CLOSURE FNHEADER) |of| FN |with| FN-OBJ)))
    FN-OBJ))

(GET-FUNCTION-DEF
  (LAMBDA (FN)                                           (* \; "Edited 20-Apr-88 15:52 by rtk")
    (COND
       ((\\CODEBLOCKP FN)
        FN)
       ((LITATOM FN)
        (|fetch| (LITATOM DEFPOINTER) |of| FN))
       ((AND (EQ (NTYPX FN)
                 \\COMPILED-CLOSURE))
        (|fetch| (COMPILED-CLOSURE FNHEADER) |of| FN)))))

(SET-NATIVE-ADDR
  (LAMBDA (FN-NAME FN-OBJ NATIVE-CODE-BLOCK NATIVE-ENTRY-POINT)
                                                             (* \; "Edited 17-Jun-88 17:11 by rtk")
    (LET ((OFFSET (NATIVE-ADDR-WORD-OFFSET FN-OBJ)))
         (PUTBASE FN-OBJ OFFSET (LRSH NATIVE-ENTRY-POINT 16))
         (PUTBASE FN-OBJ (ADD1 OFFSET)
                (LOGAND NATIVE-ENTRY-POINT 65535)))
    (|replace| (FNHEADER NATIVE) |of| FN-OBJ |with| T)))

(GET-NATIVE-ADDR
  (LAMBDA (FN-OBJ)                                       (* \; "Edited 19-May-88 16:09 by rtk")
    (|if| (FN-OBJ)
        |then| (LET* ((OFFSET (NATIVE-ADDR-WORD-OFFSET FN-OBJ))
                          (RESULT (LOGOR (LLSH (GETBASE FN-OBJ OFFSET)
                                               16)
                                         (GETBASE FN-OBJ (ADD1 OFFSET)))))
                         RESULT)
      |else| (ERROR "Illegal FN-OBJ in GET-NATIVE-ADDR"))))

(LISP-ADDR-TO-NATIVE-ADDR
  (LAMBDA (ADDR)                                         (* \; "Edited 19-May-88 12:41 by rtk")
    (|if| (EQ (MACHINETYPE)
                  'MAIKO)
        |then| (SUBRCALL GET-NATIVE-ADDR-FROM-LISP-PTR ADDR)
      |else| (LOGOR (LLSH (\\HILOC ADDR)
                              16)
                        (\\LOLOC ADDR)))))

(NATIVE-ADDR-WORD-OFFSET
  (LAMBDA (FN-OBJ)                                       (* \; "Edited 20-May-88 14:34 by rtk")
    (CL:FLOOR (- (|fetch| (FNHEADER STARTPC) |of| FN-OBJ)
                 4)
           2)))

(WALK-CODE
  (LAMBDA (CODE-BASE)                                    (* \; "Edited 20-May-88 16:18 by rtk")

(* |;;;| "This Pass  identifies jump targets, sets jump addresses, identifies  following opcodes, and other information used in the 2nd pass. ")

    (DECLARE (SPECIAL *CODE-SIZE*))
    (LET (TAG OP# (GCONST-PTRS NIL)
              (START-PC (|fetch| (FNHEADER STARTPC) |of| CODE-BASE))
              (FN-NAME (|fetch| (FNHEADER FRAMENAME) |of| CODE-BASE)))
         (PRINTOUT T "Code Walk: " FN-NAME T)
         (PROG ((CODELOC START-PC)
                B B1 B2 B3 LEN PC LEVADJ STACK-EFFECT STK NEW-REC LAST-REC)
           LP  (SETQ PC CODELOC)
               (SETQ LEN (LOCAL (|fetch| OPNARGS |of| (SETQ TAG (\\FINDOP (SETQ B
                                                                                   (GETBYTE CODE-BASE
                                                                                          )))))))
               (COND
                  ((IGREATERP LEN 0)
                   (SETQ B1 (GETBYTE CODE-BASE))))
               (COND
                  ((IGREATERP LEN 1)
                   (SETQ B2 (GETBYTE CODE-BASE))))
               (COND
                  ((IGREATERP LEN 2)
                   (SETQ B3 (GETBYTE CODE-BASE))))
               (SELECTQ (OR (AND (NEQ T (|fetch| OPPRINT |of| TAG))
                                 (|fetch| OPPRINT |of| TAG))
                            (|fetch| OPCODENAME |of| TAG))
                   (-X- (SETQ *CODE-SIZE* (IPLUS CODELOC 5))
                        (PRINTOUT T "Size of " CODE-BASE " is " *CODE-SIZE*)
                        (RETURN GCONST-PTRS))
                   (GCONST (LET* ((|const-ptr| (VAG2 B1 (LOGOR (LLSH B2 8)
                                                               B3))))
                                 (|push| GCONST-PTRS (LIST |const-ptr| CODELOC NIL))))
                   NIL)
               (GO LP)))))

(CODE-BLOCK-COPY
  (LAMBDA (SRC-FN-OBJECT SRC-START-PC SRC-CODE-SIZE SRC-ALT-CODE-OFFSET DEST-START-PC 
                 DEST-ALT-CODE-OFFSET GCONST-PTRS NEW-FN-NAME)
                                                             (* \; "Edited  9-Jun-88 12:24 by rtk")
    (LET* ((CELLS-TO-PC (CL:CEILING DEST-START-PC BYTESPERCELL))
           (INIT-ON-PAGE (CEIL (CL:1+ CELLS-TO-PC)
                               CELLSPERQUAD))
           (ALLOCATE-CODE-SIZE (CEIL (+ SRC-CODE-SIZE (- (+ DEST-START-PC DEST-ALT-CODE-OFFSET)
                                                         (+ SRC-START-PC SRC-ALT-CODE-OFFSET))
                                        BYTESPERQUAD)
                                     BYTESPERQUAD))
           (NEW-CODE-BASE (\\ALLOC.CODE.BLOCK ALLOCATE-CODE-SIZE INIT-ON-PAGE))
           (FN-HEADER-WORD-SIZE (CL:CEILING SRC-START-PC BYTESPERWORD))
           (CODE-COPY-SIZE (CL:CEILING (- SRC-CODE-SIZE (+ SRC-START-PC SRC-ALT-CODE-OFFSET))
                                  BYTESPERWORD))
           (CODE-BLT-DEST-BASE (\\ADDBASE NEW-CODE-BASE (CL:CEILING (+ DEST-START-PC 
                                                                       DEST-ALT-CODE-OFFSET)
                                                               BYTESPERWORD)))
           (CODE-BLT-SOURCE-BASE (\\ADDBASE SRC-FN-OBJECT (CL:CEILING (+ SRC-START-PC 
                                                                         SRC-ALT-CODE-OFFSET)
                                                                 BYTESPERWORD)))
           (NOP-OPCODE (CAR (\\FINDOP 'NOP))))

          (* |;;| "Copy Fn Header")

          (UNINTERRUPTABLY
              (\\BLT NEW-CODE-BASE SRC-FN-OBJECT FN-HEADER-WORD-SIZE)

              (* |;;| "Fixup References in Frame Name")

              (\\ADDREF (OR (AND NEW-FN-NAME (PROGN (|replace| (FNHEADER \#FRAMENAME)
                                                       |of| NEW-CODE-BASE |with| NEW-FN-NAME)
                                                    NEW-FN-NAME))
                            (|fetch| (FNHEADER \#FRAMENAME) |of| SRC-FN-OBJECT)))

              (* |;;| "Fixup references to debugging info ")

              (LET* ((NTSIZE (|fetch| (FNHEADER NTSIZE) |of| SRC-FN-OBJECT))
                     (TEMP (+ (UNFOLD (|fetch| (FNHEADER OVERHEADWORDS) |of| T)
                                     BYTESPERWORD)
                              (COND
                                 ((EQ NTSIZE 0)              (* \; 
                                           "No nametable, but there's a quad of zeros there anyway")
                                  BYTESPERQUAD)
                                 (T (UNFOLD NTSIZE (ITIMES 2 BYTESPERWORD))))))
                     (NEW-NTSIZE (IDIFFERENCE SRC-START-PC TEMP))
                     (DEBUG-INFO-PTR (AND (EQ NEW-NTSIZE BYTESPERCELL)
                                          (GETBASEPTR SRC-FN-OBJECT (FOLDLO TEMP BYTESPERWORD)))))
                    (|if| DEBUG-INFO-PTR
                        |then| (PRINTOUT T "Debugging Info: " DEBUG-INFO-PTR T)
                              (\\ADDREF DEBUG-INFO-PTR))))

          (* |;;| "Insert the NOPs where the GCONST to reference the native code bock will go")

          (|for| I |from| 0 |to| (SUB1 DEST-ALT-CODE-OFFSET)
             |do| (\\PUTBASEBYTE NEW-CODE-BASE (+ DEST-START-PC I)
                             NOP-OPCODE))

          (* |;;| "Copy Code & add GCONST refs")

          (UNINTERRUPTABLY
              (\\BLT CODE-BLT-DEST-BASE CODE-BLT-SOURCE-BASE CODE-COPY-SIZE)
              (|for| |ptr| |in| GCONST-PTRS
                 |do| (\\ADDREF (CAR |ptr|)) 

                       (* |;;| "Check for a re-mapped code object")

                       (|if| (CADDR |ptr|)
                           |then| (LET* ((|new-ptr| (CAR |ptr|))
                                             (|hi-val| (\\HILOC |new-ptr|))
                                             (|mid-val| (LRSH (\\LOLOC |new-ptr|)
                                                              8))
                                             (|low-val| (LOGAND 255 (\\LOLOC |new-ptr|)))
                                             (|pc-offset| (CADR |ptr|)))
                                            (\\PUTBASEBYTE NEW-CODE-BASE (+ 1 |pc-offset|)
                                                   |hi-val|)
                                            (\\PUTBASEBYTE NEW-CODE-BASE (+ 2 |pc-offset|)
                                                   |mid-val|)
                                            (\\PUTBASEBYTE NEW-CODE-BASE (+ 3 |pc-offset|)
                                                   |low-val|)))))

          (* |;;| "Fix the Start PC")

          (|replace| (FNHEADER STARTPC) |of| NEW-CODE-BASE |with| DEST-START-PC)

          (* |;;| "return the result code block ")

          NEW-CODE-BASE)))

(ADD-GCONST
  (LAMBDA (FN-OBJ OFFSET PTR)                            (* \; "Edited  1-Jun-88 12:15 by rtk")
    (LET* ((BYTE-OFFSET (+ (|fetch| (FNHEADER STARTPC) |of| FN-OBJ)
                           OFFSET))
           (HI-BLOCK (\\HILOC PTR))
           (LO-BLOCK (\\LOLOC PTR))
           (LO-BLOCK1 (LRSH LO-BLOCK 8))
           (LO-BLOCK2 (LOGAND LO-BLOCK 255))
           (POP-OP (CAR (\\FINDOP 'POP))))
          (UNINTERRUPTABLY
              (\\PUTBASEBYTE FN-OBJ BYTE-OFFSET (CAR (\\FINDOP 'GCONST)))
              (\\PUTBASEBYTE FN-OBJ (+ BYTE-OFFSET 1)
                     HI-BLOCK)
              (\\PUTBASEBYTE FN-OBJ (+ BYTE-OFFSET 2)
                     LO-BLOCK1)
              (\\PUTBASEBYTE FN-OBJ (+ BYTE-OFFSET 3)
                     LO-BLOCK2)
              (\\PUTBASEBYTE FN-OBJ (+ BYTE-OFFSET 4)
                     POP-OP)

              (* |;;| "Keep Pointer Around")

              (\\ADDREF PTR)
              T))))

(MAKE-PC-OFFSET
  (LAMBDA (CODEBASE)                                     (* \; "Edited 31-May-88 18:21 by rtk")
    (OR (AND (|fetch| (FNHEADER NATIVE) |of| CODEBASE)
             0)
        (LOGAND (+ (LOGAND (|fetch| (FNHEADER STARTPC) |of| CODEBASE)
                          3)
                   7)
               2147483644))))
)



(* |;;| "UNIX Exec Functions")

(DEFINEQ

(DO-EXEC-COMMAND
  (LAMBDA (EXEC-CMD)                                     (* \; "Edited 10-Jun-88 14:11 by rtk")
    (PRINTOUT *NATIVE-STREAM* EXEC-CMD T)
    (LET ((RETURN-CODE (IF *UNIX-STREAMS*
                           THEN (LET ((UNIX-STREAM (IL:CREATE-PROCESS-STREAM EXEC-CMD)))
                                         (SETFILEINFO UNIX-STREAM 'ENDOFSTREAMOP 
                                                'TRAN-END-OF-UNIX-STREAM)
                                         (CL:CATCH 'NATIVE-STREAM-EOF
                                             (CL:DO ((CH (READC UNIX-STREAM)
                                                         (READC UNIX-STREAM)))
                                                    (NIL)
                                                 (IF (EQ CH (CHARACTER 10))
                                                     THEN (TERPRI *NATIVE-STREAM*)
                                                   ELSE (PRIN1 CH *NATIVE-STREAM*))))
                                         (IL:UNIX-STREAM-CLOSE UNIX-STREAM))
                         ELSE (SUBRCALL OLD-COMPILE-LOAD-NATIVE EXEC-CMD))))
         (IF (NEQ 0 RETURN-CODE)
             THEN (PRINTOUT *NATIVE-STREAM* "Error in Compile: " RETURN-CODE T)
                   NIL
           ELSE T))))

(TRAN-END-OF-UNIX-STREAM
  (LAMBDA (STREAM)                                       (* \; "Edited 17-May-88 11:53 by rtk")
    (CL:THROW 'NATIVE-STREAM-EOF NIL)))
)



(* |;;| "Macros")


(DEFMACRO SWAPPED-FN-OBJ (|base|)
   `(LOGOR (LLSH (\\LOLOC ,|base|)
                 16)
           (\\HILOC ,|base|)))

(DEFMACRO FN-OBJ (|base|)
   `(LET* ((|base-addr| (LOGOR (LLSH (\\HILOC ,|base|)
                                     16)
                               (\\LOLOC ,|base|)))
           (|machine-addr| (|if| (OR (EQ (MACHINETYPE)
                                             'KATANA)
                                         (EQ (MACHINETYPE)
                                             'MAIKO))
                               THEN ((OPCODES 125 118 1)
                                         |base-addr|)
                             |else| |base-addr|)))
          |machine-addr|))

(DEFMACRO CODEBASELT (BASE BYTE-OFFSET)
   `(\\GETBASEBYTE ,BASE ,BYTE-OFFSET))

(DEFMACRO CODEBASELT2 (BASE BYTE-OFFSET)
   `(LOGOR (LLSH (CODEBASELT ,BASE ,BYTE-OFFSET)
                 BITSPERBYTE)
           (CODEBASELT ,BASE (ADD1 ,BYTE-OFFSET))))



(* |;;| "Variables")


(RPAQ? IL:*NATIVE-TEMP-FILE-DIRECTORY* "/tmp")

(RPAQ? *NATIVE-INCLUDE-FILE-DIRECTORY* NIL)

(RPAQ? *NATIVE-LISP-RUN-FILENAME* NIL)

(RPAQ? IL:*NATIVE-BIN-DIRECTORY* "/bin")

(RPAQ? *REMOVE-TEMP-NATIVE-FILES* T)

(RPAQ? *UNIX-STREAMS* NIL)

(RPAQ? *NATIVE-GCONST-OFFSET* 12)

(RPAQ? *KEEP-NATIVE-SOURCES* NIL)



(* |;;| "Makefile Environment")


(PUTPROPS NATIVE-TRANSLATOR FILETYPE TCOMPL)

(PUTPROPS NATIVE-TRANSLATOR MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE 
                                                                "NATIVE-TRANSLATOR"))
(PUTPROPS NATIVE-TRANSLATOR COPYRIGHT ("Xerox Corporation" 1988))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (7748 8192 (BYTE-TO-NATIVE-TRANSLATE 7758 . 7910) (NATIVE-TO-BYTE-UNTRANSLATE 7912 . 
8066) (IL:LINK-OBJECT-CODE 8068 . 8190)) (8193 15333 (NBT 8203 . 8968) (NATIVE-TRANS 8970 . 11418) (
NATIVE-TRANSLATE 11420 . 15331)) (15334 16601 (NUT 15344 . 16047) (FETCH-GCONST 16049 . 16599)) (16602
 23100 (LINK-C-CODE 16612 . 22795) (LINK-FN-CODE-BLOCK 22797 . 22848) (UNPACK-NUMBER 22850 . 23098)) (
23137 41022 (CODEWALK1 23147 . 34727) (SETJUMPTARGET 34729 . 41020)) (41155 57233 (CODEWALK2 41165 . 
45443) (CONDITIONAL-PARSER 45445 . 49607) (INLINE-EXPAND 49609 . 57231)) (57271 73549 (BCE-PARSER 
57281 . 57689) (STR-PARSER 57691 . 59146) (COND-PARSER 59148 . 60772) (CONST-PARSER 60774 . 60992) (
COPY-PARSER 60994 . 61920) (JUMP-PARSER 61922 . 62202) (FN-CALL-PARSER 62204 . 64807) (FN-CALL-PARSERX
 64809 . 65219) (ENVCALL-PARSER 65221 . 67300) (RETURN-PARSER 67302 . 69409) (SWAP-PARSER 69411 . 
70096) (PVAR_PARSER 70098 . 73547)) (73596 77770 (PARM-SUBSTITUTE 73606 . 75690) (TOS-CHECK 75692 . 
77768)) (77811 88828 (ADD-CASE 77821 . 79658) (ADD-PUSH-OPERAND-LINE 79660 . 82042) (
ADD-FN-HEADER-INFO 82044 . 85437) (IL-ADD-FN-HEADER-INFO 85439 . 88260) (CL-ADD-FN-HEADER-INFO 88262
 . 88826)) (88880 90676 (ADD-LINE 88890 . 89114) (ADD-OPERAND-LINE 89116 . 89600) (ADD-LF 89602 . 
89742) (ADD-ASM-LINE 89744 . 89931) (ADD-INLINE-LINE 89933 . 90448) (BCE-LINE 90450 . 90674)) (90717 
97044 (ADD-ERROR-LINE 90727 . 91205) (ADD-ERROR-ENTRY 91207 . 96351) (ADD-ERROR-SELECT 96353 . 97042))
 (97083 109518 (FIX-FILENAME 97093 . 98014) (PC-XFORM 98016 . 98229) (BCE-PC 98231 . 98471) (
ENVCALL-FN-OBJECT 98473 . 106670) (FIND-FN0-OBJECTS 106672 . 107866) (CONST-POINTERP 107868 . 107912) 
(MAKE-VAR-OFFSETS 107914 . 109516)) (109562 114251 (NEXT-OPERAND 109572 . 109871) (PUSH-ALL-OPERANDS 
109873 . 110340) (OPERAND-PUSH 110342 . 111199) (OPERAND-GET 111201 . 111780) (OPERAND-POP 111782 . 
112065) (GET-VAL 112067 . 112585) (GET-SHIFTED-VAL 112587 . 112849) (GET-INFO 112851 . 113362) (
ADD-INFO 113364 . 113820) (SET-INFO 113822 . 114249)) (114286 122368 (MAKE-PROGRAM-FILE 114296 . 
114657) (WRITE-PROGRAM-FILE 114659 . 115807) (WRITE-INLINE-FILE 115809 . 119081) (WRITE-INCLUDE-FILE 
119083 . 119718) (PRINT-CODE-LINE 119720 . 120594) (PRINT-LINE-INFO 120596 . 122366)) (122403 167483 (
TRANSLATION-INIT 122413 . 123831) (STRIP-ENDING-SLASH 123833 . 124156) (SETUP-TRANSLATION-FNS 124158
 . 124412) (MAKE-TRANSLATION-ENTRY 124414 . 131117) (MAKE-TRANSLATION-ENTRIES 131119 . 131422) (
MAKE-TRANSLATION-PATTERN-LIST 131424 . 133776) (MAKE-INLINE-LISTS 133778 . 134453) (MAKE-OPCODE-LIST 
134455 . 154399) (MAKE-ORDERING-LIST 154401 . 167481)) (167527 169494 (VERIFY-OPCODES 167537 . 168114)
 (VERIFY-OPCODE 168116 . 169492)) (169533 192240 (LOADNATIVE 169543 . 176938) (GET-NATIVE-LOAD-SIZE 
176940 . 177764) (LOAD-NATIVE-FILE 177766 . 180131) (SET-CODE-BASE 180133 . 180480) (
MAKE-NEW-CODE-BLOCK 180482 . 181406) (SET-NEW-FUNCTION-DEF 181408 . 181904) (GET-FUNCTION-DEF 181906
 . 182288) (SET-NATIVE-ADDR 182290 . 182761) (GET-NATIVE-ADDR 182763 . 183276) (
LISP-ADDR-TO-NATIVE-ADDR 183278 . 183656) (NATIVE-ADDR-WORD-OFFSET 183658 . 183892) (WALK-CODE 183894
 . 185885) (CODE-BLOCK-COPY 185887 . 190900) (ADD-GCONST 190902 . 191875) (MAKE-PC-OFFSET 191877 . 
192238)) (192280 193796 (DO-EXEC-COMMAND 192290 . 193620) (TRAN-END-OF-UNIX-STREAM 193622 . 193794))))
)
STOP
\ No newline at end of file
diff --git a/internal/library/NATIVE-TRANSLATOR-PACKAGE b/internal/library/NATIVE-TRANSLATOR-PACKAGE
new file mode 100644
index 00000000..66db7586
--- /dev/null
+++ b/internal/library/NATIVE-TRANSLATOR-PACKAGE
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "NATIVE-TRANSLATOR" (USE "IL")))
(FILECREATED "15-Jun-90 18:46:45" 
{DSK}<usr>local>lde>lispcore>internal>library>NATIVE-TRANSLATOR-PACKAGE.;2 1706   

      changes to%:  (VARS NATIVE-TRANSLATOR-PACKAGECOMS)

      previous date%: "10-Jun-88 11:23:35" 
{DSK}<usr>local>lde>lispcore>internal>library>NATIVE-TRANSLATOR-PACKAGE.;1)


(* ; "
Copyright (c) 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT NATIVE-TRANSLATOR-PACKAGECOMS)

(RPAQQ NATIVE-TRANSLATOR-PACKAGECOMS (

(* ;;; "Setting up the TRANSLATOR package.")

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

                                          (PROP MAKEFILE-ENVIRONMENT NATIVE-TRANSLATOR-PACKAGE)))



(* ;;; "Setting up the TRANSLATOR package.")


(DEFPACKAGE "NATIVE-TRANSLATOR" (:NICKNAMES "NT")
       (:USE "IL"))



(* ;; "Arrange for the correct makefile environment")


(PUTPROPS NATIVE-TRANSLATOR-PACKAGE MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE
                                                                        (DEFPACKAGE 
                                                                               "NATIVE-TRANSLATOR"
                                                                               (:USE "IL"))))
(PUTPROPS NATIVE-TRANSLATOR-PACKAGE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/internal/library/NEWNSMAIL b/internal/library/NEWNSMAIL
new file mode 100644
index 00000000..d299c587
--- /dev/null
+++ b/internal/library/NEWNSMAIL
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "26-Sep-90 11:35:28" "{tigger/n}<tigger>lafite>sources>NEWNSMAIL;42" 86998  

      changes to%:  (VARS NEWNSMAILCOMS *NSMAIL-RETURN-CONTENTS* *NSMAIL-ALLOW-DL-RECIPIENTS* \NSMAIL.HEADING.ATTRIBUTES)
 (FNS \NSMAIL.NEW.PRINT.HEADING NULL.NSNAME \NSMAIL.READ.BODY.PARTS \NSMAIL.BUILD.HEADING \NSMAIL.GDATE \NSMAIL.EMIT.ANNOTATION \NSMAIL.NEW.CHECKSERVER \NSMAIL.HANDLE.DELIVERY.REPORT \NSMAIL.NEW.SEND \NSMAIL.NEW.FINDSERVER \NSMAIL.COPY.NSTEXTFILE \NSMAIL.EMIT.FORWARDING \NSMAIL.SKIP.LINES LA.TRIM.WHITESPACE \NSMAIL.TRANSLATE.IP.MESSAGEID \NSMAIL.MAYBE.QUOTE)
 (COURIERPROGRAMS NEW.MAILTRANSPORT)

      previous date%: " 4-Apr-90 17:42:21" "{tigger/n}<tigger>lafite>sources>NEWNSMAIL;20")


(* "
Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT NEWNSMAILCOMS)

(RPAQQ NEWNSMAILCOMS ((COURIERPROGRAMS NEW.MAILTRANSPORT NEW.INBASKET) (COMS (* ; "Courier type EnvelopeItem") (FNS \NS.NEW.READ.ENVELOPE.ITEM \NS.NEW.WRITE.ENVELOPE.ITEM) (VARS \NSMAIL.NEW.ENVELOPE.ITEM.TYPES) (PROP COURIERDEF NEW.ENVELOPE.ITEM)) (COMS (* ; "Courier type HeadingAttribute") (FNS \NS.READ.HEADING.ATTRIBUTE \NS.WRITE.HEADING.ATTRIBUTE) (VARS \NSMAIL.HEADING.ATTRIBUTES) (PROP COURIERDEF HEADING.ATTRIBUTE)) (COMS (* ; "Courier type RName") (FNS \NSMAIL.READ.RNAME \NSMAIL.WRITE.RNAME \NSMAIL.RNAME.LENGTH) (PROP COURIERDEF NEW.RNAME) (FNS RNAME.TO.STRING X400.NAME.TO.STRING EQUAL.RNAMES)) (COMS (* ; "Posting") (FNS \NSMAIL.NEW.SEND.PARSE \NSMAIL.CHECK.ENUMERATION \NSMAIL.NEW.SEND \NSMAIL.NEW.INVALID.RECIPIENTS \NSMAIL.BUILD.HEADING \NSMAIL.POST.BODY.PART \NSMAIL.NEW.PREPARE.ATTACHMENT \NSMAIL.CHECK.ABORT \NSMAIL.NEW.FINDSERVER \NSMAIL.NEW.CHECKSERVER) (VARS NSMAIL.PARSEFIELDS (\LAPARSE.NSMAIL (LAFITE.MAKE.PARSE.TABLE NSMAIL.PARSEFIELDS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (AND (CCODEP (QUOTE \NSMAIL.NEW.SEND.PARSE)) (MOVD (QUOTE \NSMAIL.NEW.SEND.PARSE) (QUOTE \NSMAIL.SEND.PARSE) NIL T)))) (INITVARS (*USE-NEW-NSMAIL* T) (*NEWNSMAIL-POST-AS-TEXTFILE* :TEST) (*NEWNSMAIL-REPORT-TYPE* (QUOTE NON.DELIVERY.ONLY)) (*NSMAIL-ALLOW-DL-RECIPIENTS* T) (*NSMAIL-RETURN-CONTENTS* T) (*NSMAIL-MIN-WILLINGNESS* 9) (*NSMAIL-TRACE-SERVERS*) (*NSMAIL-GENERATE-MESSAGE-ID*) (*NSMAIL-DISPLAY-TRANSPORT-ID*) (*NSMAIL-DISPLAY-POSTMARK*) (*NSMAIL-DISPLAY-ERRORS-TO*) (*NSMAIL-CACHE-TIMEOUT* (TIMES 1000 60 60)) (\NSMAIL.MIN.VP.TYPE 4300) (\NSMAIL.MAX.VP.TYPE 5200) (\NSMAIL.NEW.SERVER.CACHE)) (GLOBALVARS \NSMAIL.NEW.SERVER.CACHE \NSMAIL.MIN.VP.TYPE \NSMAIL.MAX.VP.TYPE) (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *USE-NEW-NSMAIL* *NEWNSMAIL-POST-AS-TEXTFILE* *NEWNSMAIL-REPORT-TYPE* *NSMAIL-ALLOW-DL-RECIPIENTS* *NSMAIL-RETURN-CONTENTS* *NSMAIL-MIN-WILLINGNESS* *NSMAIL-TRACE-SERVERS* *NSMAIL-GENERATE-MESSAGE-ID* *NSMAIL-DISPLAY-TRANSPORT-ID* *NSMAIL-DISPLAY-POSTMARK* *NSMAIL-DISPLAY-ERRORS-TO* *NSMAIL-CACHE-TIMEOUT*))))) (COMS (* ; "Retrieving") (FNS \NSMAIL.NEW.AUTHENTICATE NEWNS.POLLNEWMAIL NEWNS.OPENMAILBOX \NSMAIL.NEW.CHECK NEWNS.NEXTMESSAGE NEWNS.RETRIEVEMESSAGE \NSMAIL.READ.BODY.PARTS \NSMAIL.COPY.IA5 \NSMAIL.COPY.NSTEXTFILE \NSMAIL.READ.HEADING \NSMAIL.PARSE.ANNOTATION \NSMAIL.EMIT.ANNOTATION LA.TRIM.WHITESPACE \NSMAIL.READ.FORWARDING \NSMAIL.NEW.PRINT.HEADING \NSMAIL.NEW.PRINT.NAMES \NSMAIL.EMIT.FORWARDING \NSMAIL.GDATE \NSMAIL.TRANSLATE.IP.MESSAGEID \NSMAIL.MAYBE.QUOTE NULL.NSNAME \NSMAIL.HANDLE.DELIVERY.REPORT \NSMAIL.RECIPIENT.NAME NEW.INBASKET.CALL NEWNS.CLOSEMAILBOX \NSMAIL.NEW.LOGOFF) (VARS \NSMAIL.GOOD.BODY.PARTS \NSMAIL.DISCARDABLE.BODY.PARTS) (GLOBALVARS \NSMAIL.GOOD.BODY.PARTS \NSMAIL.DISCARDABLE.BODY.PARTS) (ALISTS (LAFITEMODELST NS)) (P (LAFITEMODE (LAFITEMODE)) (COND ((AND *USE-NEW-NSMAIL* \LAFITE.ACTIVE) (* ; "recache") (LAFITECLEARCACHE))))) (COMS (* ; "Old ns mail") (FNS \NS.READ.ENVELOPE.ITEM \NS.WRITE.ENVELOPE.ITEM) (VARS \NSMAIL.ENVELOPE.ITEM.TYPES)) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (RECORDS FORWARD) (MACROS \COMPUTED.FORM \NSMAIL.BODY.PART.TYPE) (GLOBALVARS \NSMAIL.BODY.PART.TYPES \NSMAIL.HEADING.ATTRIBUTES) (FILES (SOURCE) LAFITEDECLS) (FILES (LOADCOMP) NSMAIL) (CONSTANTS * \NSMAIL.CONTENTS.TYPES) (* ; "This one we need at run time also") DOCOPY (VARS \NSMAIL.BODY.PART.TYPES)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA NEW.INBASKET.CALL)))))

(COURIERPROGRAM NEW.MAILTRANSPORT (17 5)
    TYPES
      ((CREDENTIALS (AUTHENTICATION . CREDENTIALS)) (VERIFIER (AUTHENTICATION . VERIFIER)) (SESSION (RECORD (TOKEN (ARRAY 2 UNSPECIFIED)) (VERIFIER VERIFIER))) (ENVELOPE.ITEM.TYPE LONGCARDINAL) (ENVELOPE (SEQUENCE NEW.ENVELOPE.ITEM)) (INVALID.NAME (RECORD (ID CARDINAL) (REASON INVALID.REASON))) (INVALID.NAME.LIST (SEQUENCE INVALID.NAME)) (INVALID.REASON (ENUMERATION (NoSuchRecipient 0) (NoMailboxForRecipient 1) (IllegalName 2) (NoDlsAllowed 3) (ReportNotAllowed 4))) (NAME NSNAME) (RNAME NEW.RNAME (* ; "(choice (xns 0 name) (gateway 1 gateway.name))")) (RNAME.LIST (SEQUENCE RNAME)) (GATEWAY.NAME (RECORD (COUNTRY STRING) (ADMIN.DOMAIN STRING) (PRIVATE.DOMAIN STRING) (ORGANIZATION STRING) (ORGANIZATIONAL.UNITS (SEQUENCE STRING)) (PERSONAL (CHOICE (WHOLE 0 STRING) (BROKEN 1 BROKEN.NAME))) (GATEWAY.SPECIFIC.INFORMATION (SEQUENCE X400.ATTRIBUTE)))) (BROKEN.NAME (RECORD (GIVEN STRING) (INITIALS STRING) (FAMILY STRING) (GENERATION STRING))) (X400.ATTRIBUTE (RECORD (TYPE STRING) (VALUE STRING))) (REPORT.TYPE (ENUMERATION (NONE 0) (NON.DELIVERY.ONLY 1) (ALL 2))) (RECIPIENT (RECORD (NAME RNAME) (RECIPIENT.ID CARDINAL) (REPORT REPORT.TYPE))) (RECIPIENT.LIST (SEQUENCE RECIPIENT)) (WILLINGNESS (SEQUENCE WILLINGNESS.METRIC)) (WILLINGNESS.METRIC CARDINAL) (BODY.PART.TYPE LONGCARDINAL) (CONTENTS.TYPE LONGCARDINAL) (MESSAGEID (ARRAY 5 UNSPECIFIED)) (POSTING.DATA (RECORD (RECIPIENTS RECIPIENT.LIST) (CONTENTS.TYPE CONTENTS.TYPE) (CONTENTS.SIZE LONGCARDINAL) (BODY.PART.TYPES.SEQUENCE (SEQUENCE BODY.PART.TYPE)))) (POSTMARK (RECORD (POSTED.AT RNAME) (TIME TIME))) (TOC (SEQUENCE TOC.ITEM)) (TOC.ITEM (RECORD (TYPE BODY.PART.TYPE) (SIZE LONGCARDINAL))) (REPORT (RECORD (ORIGINAL.ENVELOPE ENVELOPE) (FATE (CHOICE (DELIVERED 0 (ENUMERATION (CONTENTS.TRUNCATED 0) (NO.PROBLEM 1))) (NOT.DELIVERED 1 (RECORD (REASON NON.DELIVERY.REASON) (POSTMARK POSTMARK))))) (REPORT.TYPE (CHOICE (DLMEMBER 0 DLREPORT) (OTHER 1 OTHER.REPORT))))) (DLREPORT (RECORD (DLNAME RNAME) (INVALID.RECIPIENTS (SEQUENCE NON.DELIVERED.RECIPIENT)))) (OTHER.REPORT (RECORD (SUCCEEDED (SEQUENCE DELIVERED.RECIPIENT)) (FAILED (SEQUENCE NON.DELIVERED.RECIPIENT)))) (DELIVERED.RECIPIENT (RECORD (RECIPIENT RECIPIENT) (WHEN TIME))) (NON.DELIVERED.RECIPIENT (RECORD (RECIPIENT RECIPIENT) (REASON NON.DELIVERY.REASON))) (NON.DELIVERY.REASON (ENUMERATION (NoSuchRecipient 0) (NoMailboxForRecipient 1) (IllegalName 2) (Timeout 3) (ReportNotAllowed 4) (MessageTooLong 5) (AmbiguousRName 6) (IllegalCharacters 7) (UnsupportedBodyParts 8) (UnsupportedContentsType 9) (TransientProblem 10) (ContentSyntaxError 11) (TooManyRecipients 12) (ProtocolViolation 13) (X400PragmaticConstraintViolation 14) (x400NoBilateralAgreement 15) (AccessRightsInsufficientForDL 16) (Other 17))) (TRANSPORT.OPTIONS (RECORD (RETURN.OF.CONTENTS BOOLEAN) (ALTERNATE.RECIPIENT.ALLOWED BOOLEAN))) (PRIORITY (ENUMERATION (NonUrgent 0) (Normal 1) (Urgent 2))) (CONVERTED.ITEM (ENUMERATION (IA5TextToTeletex 0) (TeletexToTelex 1) (TeletexToIA5Text 2) (TelexToTeletex 3))) (IP.MESSAGEID (RECORD (ORIGINATOR RNAME) (UNIQUESTRING STRING))) (AUTHENTICATION.LEVEL (ENUMERATION (Strong 0) (Simple 1) (Foreign 2))) (FORWARDED.MESSAGE.INFO (RECORD (ENVELOPE ENVELOPE) (HEADING (SEQUENCE HEADING.ATTRIBUTE)) (ASSOCIATED.BODY.PARTS (SEQUENCE BODY.PART.INDEX)) (INDEX.OF.PARENT.HEADING (CHOICE (NULL 0 (RECORD)) (NESTED 1 CARDINAL))))) (BODY.PART.INDEX CARDINAL) (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0) (ServiceFull 1) (ServiceUnavailable 2) (MediumFull 3))) (TRANSFER.PROBLEM (ENUMERATION (Aborted 0))) (OTHER.PROBLEM (ENUMERATION (Can'tExpedite 0) (MalformedMessage 1) (IncorrectContentsSize 2) (LAST 65535))) (SESSION.PROBLEM (ENUMERATION (InvalidHandle 0) (WrongState 1))))
    PROCEDURES
      ((SERVER.POLL 0 NIL RETURNS (WILLINGNESS (CLEARINGHOUSE . NETWORK.ADDRESS.LIST) NAME)) (BEGIN.POST 1 (POSTING.DATA BOOLEAN BOOLEAN (SEQUENCE NEW.ENVELOPE.ITEM) CREDENTIALS VERIFIER) RETURNS (SESSION INVALID.NAME.LIST) REPORTS (AUTHENTICATION.ERROR INVALID.RECIPIENTS SERVICE.ERROR OTHER.ERROR)) (MAILPOLL 7 (NAME CREDENTIALS VERIFIER) RETURNS (BOOLEAN) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR OTHER.ERROR)) (POST.ONE.BODY.PART 8 (SESSION BODY.PART.TYPE BULK.DATA.SOURCE) RETURNS NIL REPORTS (AUTHENTICATION.ERROR SERVICE.ERROR OTHER.ERROR SESSION.ERROR TRANSFER.ERROR)) (END.POST 9 (SESSION BOOLEAN) RETURNS (MESSAGEID) REPORTS (AUTHENTICATION.ERROR SERVICE.ERROR OTHER.ERROR SESSION.ERROR TRANSFER.ERROR)))
    ERRORS
      ((ACCESS.ERROR 0 (ACCESS.PROBLEM)) (AUTHENTICATION.ERROR 1 ((AUTHENTICATION . PROBLEM))) (INVALID.RECIPIENTS 3 (INVALID.NAME.LIST)) (SERVICE.ERROR 4 (SERVICE.PROBLEM)) (TRANSFER.ERROR 5 (TRANSFER.PROBLEM)) (OTHER.ERROR 6 (OTHER.PROBLEM)) (SESSION.ERROR 7 (SESSION.PROBLEM)))
)

(COURIERPROGRAM NEW.INBASKET (18 2)
    INHERITS
      (NEW.MAILTRANSPORT)
    TYPES
      ((CREDENTIALS (AUTHENTICATION . CREDENTIALS)) (VERIFIER (AUTHENTICATION . VERIFIER)) (NAME NSNAME) (INDEX LONGCARDINAL) (RANGE (RECORD (LOW INDEX) (HIGH INDEX))) (MESSAGE.STATUS (RECORD (USER.DEFINED.STATUS CARDINAL) (EXISTENCE.OF.MESSAGE (ENUMERATION (NEW 0) (KNOWN 1))))) (BODY.PART.SEQUENCE (SEQUENCE BODY.PART.INDEX)) (BODY.PART.STATUS (SEQUENCE BOOLEAN)) (BODY.PART.STATUS.CHANGE (RECORD (BODY.PART.INDEX BODY.PART.INDEX) (DELETABLE (ENUMERATION (TRUE 0) (NOCHANGE 1))))) (BODY.PART.STATUS.CHANGE.SEQUENCE (SEQUENCE BODY.PART.STATUS.CHANGE)) (STATUS (RECORD (MESSAGE.STATUS MESSAGE.STATUS) (BODY.PART.STATUS BODY.PART.STATUS))) (SESSION (RECORD (TOKEN (ARRAY 2 UNSPECIFIED)) (VERIFIER VERIFIER))) (ANCHOR (ARRAY 5 UNSPECIFIED)) (STATE (RECORD (NEW CARDINAL) (TOTAL CARDINAL))) (WHICH.MESSAGE (ENUMERATION (THIS 0) (NEXT 1))) (ACCESS.PROBLEM (ENUMERATION (AccessRightsInsufficient 0) (AccessRightsIndeterminate 1) (NoSuchInbasket 2) (InbasketIndeterminate 3) (WrongService 4))) (CONNECTION.PROBLEM (FILING . CONNECTION.PROBLEM)) (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0) (ServiceFull 1) (ServiceUnavailable 2))) (TRANSFER.PROBLEM (ENUMERATION (Aborted 0))) (SESSION.PROBLEM (ENUMERATION (TokenInvalid 0))) (OTHER.PROBLEM (ENUMERATION (USE.COURIER 0) (MalformedMessage 1) (InvalidOperation 2) (LAST 65535))) (INDEX.PROBLEM (ENUMERATION (InvalidIndex 0) (InvalidBodyPartIndex 1))))
    PROCEDURES
      ((LOGON 5 (NAME CREDENTIALS VERIFIER) RETURNS (SESSION STATE ANCHOR) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR INBASKET.IN.USE SERVICE.ERROR OTHER.ERROR)) (LOGOFF 4 (SESSION) RETURNS NIL REPORTS (AUTHENTICATION.ERROR SESSION.ERROR OTHER.ERROR)) (MAILPOLL 7 (NAME CREDENTIALS VERIFIER) RETURNS (STATE) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR OTHER.ERROR)) (MAILCHECK 6 (SESSION) RETURNS (STATE) REPORTS (AUTHENTICATION.ERROR SESSION.ERROR SERVICE.ERROR OTHER.ERROR)) (RETRIEVE.ENVELOPES 2 (INDEX WHICH.MESSAGE SESSION) RETURNS (ENVELOPE STATUS INDEX)) (RETRIEVE.BODY.PARTS 8 (INDEX BODY.PART.SEQUENCE BULK.DATA.SINK SESSION) RETURNS NIL REPORTS (AUTHENTICATION.ERROR INDEX.ERROR SESSION.ERROR SERVICE.ERROR OTHER.ERROR TRANSFER.ERROR)) (CHANGE.MESSAGE.STATUS 0 (RANGE BOOLEAN CARDINAL SESSION) RETURNS NIL REPORTS (AUTHENTICATION.ERROR INDEX.ERROR SESSION.ERROR SERVICE.ERROR OTHER.ERROR)) (CHANGE.BODY.PARTS.STATUS 3 (INDEX BODY.PART.STATUS.CHANGE.SEQUENCE SESSION) RETURNS (BOOLEAN) REPORTS (AUTHENTICATION.ERROR INDEX.ERROR SESSION.ERROR SERVICE.ERROR OTHER.ERROR)) (DELETE 1 (RANGE SESSION) RETURNS NIL REPORTS (AUTHENTICATION.ERROR SESSION.ERROR SERVICE.ERROR OTHER.ERROR)) (GET.SIZE 10 (NAME CREDENTIALS VERIFIER) RETURNS (LONGCARDINAL) REPORTS (AUTHENTICATION.ERROR ACCESS.ERROR SERVICE.ERROR OTHER.ERROR)))
    ERRORS
      ((ACCESS.ERROR 0 (ACCESS.PROBLEM)) (AUTHENTICATION.ERROR 1 ((AUTHENTICATION . PROBLEM))) (SESSION.ERROR 5 (SESSION.PROBLEM)) (SERVICE.ERROR 6 (SERVICE.PROBLEM)) (TRANSFER.ERROR 7 (TRANSFER.PROBLEM)) (OTHER.ERROR 8 (OTHER.PROBLEM)) (INDEX.ERROR 9 (INDEX.PROBLEM)) (INBASKET.IN.USE 10 (NAME)))
)



(* ; "Courier type EnvelopeItem")

(DEFINEQ

(\NS.NEW.READ.ENVELOPE.ITEM
(LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 22-Nov-89 12:53 by bvm") (* ;; "Reads a mailing envelope attribute value pair from STREAM, returning a list of two elements, (TYPE VALUE);  if the attribute is not a known attribute, TYPE is an integer and VALUE is a sequence of unspecified") (LET* ((TYPE (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) (VALUETYPE (\COMPUTED.FORM (BQUOTE (CASE TYPE (\,@ (for TRIPLE in \NSMAIL.NEW.ENVELOPE.ITEM.TYPES collect (BQUOTE ((\, (CADR TRIPLE)) (SETQ TYPE (QUOTE (\, (CAR TRIPLE)))) (QUOTE (\, (CADDR TRIPLE)))))))))))) (LIST TYPE (if VALUETYPE then (\WIN STREAM) (* ; "Skip sequence count") (COURIER.READ STREAM PROGRAM VALUETYPE) else (COURIER.READ.SEQUENCE STREAM NIL (QUOTE UNSPECIFIED))))))
)

(\NS.NEW.WRITE.ENVELOPE.ITEM
(LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 22-Nov-89 12:53 by bvm") (* ;;; "Writes a filing attribute value pair to STREAM.  ITEM is a list of two elements (TYPE VALUE)") (LET ((TYPE (CAR ITEM)) (VALUE (CADR ITEM)) VALUETYPE) (COURIER.WRITE STREAM (OR (FIXP TYPE) (\COMPUTED.FORM (BQUOTE (CASE TYPE (\,@ (for TRIPLE in \NSMAIL.NEW.ENVELOPE.ITEM.TYPES collect (BQUOTE ((\, (CAR TRIPLE)) (SETQ VALUETYPE (QUOTE (\, (CADDR TRIPLE)))) (QUOTE (\, (CADR TRIPLE))))))) (T (ERROR "Unknown Envelope Item Type" TYPE)))))) NIL (QUOTE LONGCARDINAL)) (COND (VALUETYPE (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE PROGRAM VALUETYPE)) (T (COURIER.WRITE.SEQUENCE STREAM VALUE PROGRAM (QUOTE UNSPECIFIED))))))
)
)

(RPAQQ \NSMAIL.NEW.ENVELOPE.ITEM.TYPES ((Postmark 0 POSTMARK) (Message-ID 1 MESSAGEID) (ContentsType 2 CONTENTS.TYPE) (TOC 3 TOC) (CONTENTS.SIZE 4 LONGCARDINAL) (Originator 5 RNAME) (REPORT 6 REPORT) (RETURN.TO.NAME 7 RNAME) (Previous-Recipients 8 RECIPIENT.LIST) (GatewayPostmark 9 POSTMARK) (AddressChangeNotice 10 RNAME) (TRANSPORT.OPTIONS 11 TRANSPORT.OPTIONS) (X400SpecificReportInformation 12 (SEQUENCE (SEQUENCE UNSPECIFIED))) (OtherRecipients 13 RECIPIENT.LIST) (Priority 14 PRIORITY) (Converted 15 (SEQUENCE CONVERTED.ITEM)) (AuthenticationLevelOfSender 16 AUTHENTICATION.LEVEL)))

(PUTPROPS NEW.ENVELOPE.ITEM COURIERDEF (\NS.NEW.READ.ENVELOPE.ITEM \NS.NEW.WRITE.ENVELOPE.ITEM))



(* ; "Courier type HeadingAttribute")

(DEFINEQ

(\NS.READ.HEADING.ATTRIBUTE
(LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 25-Jan-90 16:59 by bvm") (* ;; "Reads a mail heading attribute value pair from STREAM, returning a list of two elements, (TYPE VALUE);  if the attribute is not a known attribute, TYPE is an integer and VALUE is a sequence of unspecified") (bind (TYPE _ (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) for X in \NSMAIL.HEADING.ATTRIBUTES when (EQ (CADR X) TYPE) do (RETURN (LIST* (CAR X) (LET* ((RANDP (RANDACCESSP STREAM)) (END (+ (UNFOLD (\WIN STREAM) BYTESPERWORD) (if RANDP then (GETFILEPTR STREAM) else 0))) HERE) (CONS (COURIER.READ STREAM (OR PROGRAM (QUOTE NEW.MAILTRANSPORT)) (CADDR X)) (if (AND RANDP (NOT (EQL (SETQ HERE (GETFILEPTR STREAM)) END))) then (if (> HERE END) then (HELP "Heading attribute overran by " (- HERE END)) else (to (- END HERE) collect (BIN STREAM)))))))) finally (* ; "TYPE not recognized") (RETURN (LIST TYPE (COURIER.READ.SEQUENCE STREAM NIL (QUOTE UNSPECIFIED))))))
)

(\NS.WRITE.HEADING.ATTRIBUTE
(LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 22-Nov-89 18:17 by bvm") (* ;;; "Writes a mail heading attribute value pair to STREAM.  ITEM is a list of two elements (TYPE VALUE)") (PROG ((TYPE (CAR ITEM)) (VALUE (CADR ITEM)) VALUETYPE) (COND ((NOT (FIXP TYPE)) (for X in \NSMAIL.HEADING.ATTRIBUTES when (EQ (CAR X) TYPE) do (SETQ TYPE (CADR X)) (SETQ VALUETYPE (CADDR X)) (RETURN) finally (ERROR "Unknown Heading Attribute Type" TYPE)))) (COURIER.WRITE STREAM TYPE NIL (QUOTE LONGCARDINAL)) (COND (VALUETYPE (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE PROGRAM VALUETYPE)) (T (COURIER.WRITE.SEQUENCE STREAM VALUE PROGRAM (QUOTE UNSPECIFIED))))))
)
)

(RPAQQ \NSMAIL.HEADING.ATTRIBUTES ((Message-ID 1 IP.MESSAGEID) (Sender 2 RNAME) (From 3 RNAME.LIST) (To 4 RNAME.LIST) (cc 5 RNAME.LIST) (bcc 6 RNAME.LIST) (In-Reply-to 7 IP.MESSAGEID) (Obsoletes 8 (SEQUENCE IP.MESSAGEID)) (References 9 (SEQUENCE IP.MESSAGEID)) (Subject 10 STRING) (Expiration-Date 11 TIME) (Reply-By 12 TIME) (Reply-to 13 RNAME.LIST) (Importance 14 (ENUMERATION (Low 0) (Normal 1) (High 2))) (Sensitivity 15 (ENUMERATION (Personal 0) (Private 1) (CompanyConfidential 2))) (Auto-Forwarded 16 BOOLEAN) (Immutable 17 (RECORD)) (Reply-Requested-of 18 RNAME.LIST) (TextAnnotation 19 STRING) (ForwardedHeadings 20 (SEQUENCE FORWARDED.MESSAGE.INFO)) (newTextAnnotation 199 STRING) (BodyOffset 198 LONGCARDINAL) (LispFormatting 4911 STRING)))

(PUTPROPS HEADING.ATTRIBUTE COURIERDEF (\NS.READ.HEADING.ATTRIBUTE \NS.WRITE.HEADING.ATTRIBUTE))



(* ; "Courier type RName")

(DEFINEQ

(\NSMAIL.READ.RNAME
(LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 29-Nov-89 12:53 by bvm") (* ;; "Special code to read newmailtransport.rname, whose definition is (choice (xns 0 name) (gateway 1 gateway.name)).  The xns name we return as an NSNAME object, all other types as if they had been read as the definition reads.") (LET ((CHOICE (\WIN STREAM))) (CASE CHOICE (0 (COURIER.READ.NSNAME STREAM PROGRAM (QUOTE NSNAME))) (1 (LIST (QUOTE GATEWAY) (COURIER.READ STREAM PROGRAM (QUOTE GATEWAY.NAME)))) (T (ERROR "Not a recognized type of RNAME" CHOICE)))))
)

(\NSMAIL.WRITE.RNAME
(LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 29-Nov-89 12:52 by bvm") (* ;; "Special code to write newmailtransport.rname.  ITEM can be an NSNAME or a list (GATEWAY gatewayname).") (if (TYPEP ITEM (QUOTE NSNAME)) then (\WOUT STREAM 0) (COURIER.WRITE.NSNAME STREAM ITEM PROGRAM (QUOTE NSNAME)) elseif (EQ (CAR (LISTP ITEM)) (QUOTE GATEWAY)) then (\WOUT STREAM 1) (COURIER.WRITE STREAM (CADR ITEM) PROGRAM (QUOTE GATEWAY.NAME)) else (ERROR "ARG not RNAME" ITEM)))
)

(\NSMAIL.RNAME.LENGTH
(LAMBDA (ITEM PROGRAM TYPE) (* ; "Edited 29-Nov-89 21:22 by bvm") (+ 1 (if (TYPEP ITEM (QUOTE NSNAME)) then (COURIER.NSNAME.LENGTH ITEM PROGRAM (QUOTE NSNAME)) elseif (EQ (CAR (LISTP ITEM)) (QUOTE GATEWAY)) then (COURIER.REP.LENGTH (CADR ITEM) PROGRAM (QUOTE GATEWAY.NAME)) else (ERROR "ARG not RNAME" ITEM))))
)
)

(PUTPROPS NEW.RNAME COURIERDEF (\NSMAIL.READ.RNAME \NSMAIL.WRITE.RNAME \NSMAIL.RNAME.LENGTH))
(DEFINEQ

(RNAME.TO.STRING
(LAMBDA (NAME FULLFLG) (* ; "Edited  4-Apr-90 17:26 by bvm") (CL:ETYPECASE NAME (NSNAME (NSNAME.TO.STRING NAME FULLFLG)) (LIST (X400.NAME.TO.STRING NAME))))
)

(X400.NAME.TO.STRING
(LAMBDA (NAME) (* ; "Edited  4-Apr-90 17:27 by bvm") (LET ((SLASH "/") TMP) (if (NEQ (CAR NAME) (QUOTE GATEWAY)) then (ERROR "ARG NOT X400 NAME" NAME) else (SETQ NAME (CADR NAME))) (CONCATLIST (BQUOTE ((\, SLASH) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) COUNTRY of NAME)) (LIST "C=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) ADMIN.DOMAIN of NAME)) (LIST "ADMD=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) PRIVATE.DOMAIN of NAME)) (LIST "PRMD=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) ORGANIZATION of NAME)) (LIST "O=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) ORGANIZATIONAL.UNITS of NAME)) (for UNIT in TMP join (LIST "OU=" UNIT SLASH)))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) PERSONAL of NAME)) (CASE (CAR TMP) (WHOLE (LIST "PN=" (CADR TMP) SLASH)) (BROKEN (LET ((BROKEN (CADR TMP))) (BQUOTE ((\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . BROKEN.NAME) GIVEN of BROKEN)) (LIST "G=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . BROKEN.NAME) INITIALS of BROKEN)) (LIST "I=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . BROKEN.NAME) FAMILY of BROKEN)) (LIST "S=" TMP SLASH))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . BROKEN.NAME) GENERATION of BROKEN)) (LIST "GQ=" TMP SLASH)))))))))) (\,. (AND (SETQ TMP (COURIER.FETCH (NEW.MAILTRANSPORT . GATEWAY.NAME) GATEWAY.SPECIFIC.INFORMATION of NAME)) (for PAIR in TMP join (LIST (CAR PAIR) "=" (CADR PAIR) SLASH)))))))))
)

(EQUAL.RNAMES
(LAMBDA (NAME1 NAME2) (* ; "Edited  4-Apr-90 17:21 by bvm") (if (type? NSNAME NAME1) then (AND (type? NSNAME NAME2) (EQUAL.CH.NAMES NAME1 NAME2)) else (EQUAL NAME1 NAME2)))
)
)



(* ; "Posting")

(DEFINEQ

(\NSMAIL.NEW.SEND.PARSE
(LAMBDA (MSG EDITORWINDOW) (* ; "Edited 24-Jan-90 16:36 by bvm") (PROG ((SENDER (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*)) RECIPIENTS MSGFIELDS FORMATTEDP HEADEREOF INTERESTINGFIELDS SUBJECT ATTACHMENT) (OR (SETQ MSGFIELDS (\LAFITE.PREPARE.SEND MSG EDITORWINDOW \LAPARSE.NSMAIL)) (RETURN)) (COND ((EQ (CAAR MSGFIELDS) (QUOTE EOF)) (SETQ HEADEREOF (CADR (pop MSGFIELDS))))) (for PAIR in MSGFIELDS do (SELECTQ (CAR PAIR) ((To cc From Reply-to) (push INTERESTINGFIELDS (RPLACD PAIR (\NSMAIL.PARSE (CDR PAIR) SENDER EDITORWINDOW))) (SELECTQ (CAR PAIR) ((To cc) (LET ((EXPANDED (for NAME in (CDR PAIR) join (if (CL:STRING= (fetch NSDOMAIN of NAME) ";") then (* ; "DL syntax") (\NSMAIL.EXPAND.DL (fetch NSOBJECT of NAME) SENDER EDITORWINDOW) else (LIST NAME))))) (SETQ RECIPIENTS (COND (RECIPIENTS (NS.REMOVEDUPLICATES (APPEND EXPANDED RECIPIENTS))) (T EXPANDED))))) (PROGN (* ; "Might want to check validity of From and Reply-to") NIL))) ((Subject In-Reply-to) (LET ((STR (COND ((CDDR PAIR) (* ; "Make one string") (CONCATLIST (CDR PAIR))) (T (CADR PAIR))))) (COND ((EQ (CAR PAIR) (QUOTE Subject)) (SETQ SUBJECT STR)) (*USE-NEW-NSMAIL* (* ; "format is different in new protocol") (SETQ STR (COURIER.CREATE (NEW.MAILTRANSPORT . IP.MESSAGEID) ORIGINATOR _ (create NSNAME NSOBJECT _ "" NSDOMAIN _ "" NSORGANIZATION _ "") UNIQUESTRING _ STR)))) (RPLACD PAIR STR) (push INTERESTINGFIELDS PAIR))) (Date (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Date not allowed")) (Sender (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Sender not allowed")) (Format (SETQ FORMATTEDP (SELECTQ (CADR PAIR) (TEDIT T) NIL))) ((REFERENCE ATTACHMENT) (if ATTACHMENT then (\SENDMESSAGEFAIL EDITORWINDOW "Can only send a single attachment")) (SETQ ATTACHMENT T) (push INTERESTINGFIELDS PAIR)) ((Importance Sensitivity Immutable) (if (AND *USE-NEW-NSMAIL* (> (NCHARS (CADR PAIR)) 0) (SETQ PAIR (\NSMAIL.CHECK.ENUMERATION PAIR EDITORWINDOW))) then (push INTERESTINGFIELDS PAIR))) NIL)) (COND ((NULL RECIPIENTS) (\SENDMESSAGEFAIL EDITORWINDOW "No recipients!"))) (OR FORMATTEDP (SELECTQ (\LAFITE.CHOOSE.MSG.FORMAT MSG NIL EDITORWINDOW) (TEDIT (SETQ FORMATTEDP T)) (NIL (* ; "Aborted") (RETURN)) NIL)) (RETURN (create NSMAILPARSE NSPSUBJECT _ SUBJECT NSPRECIPIENTS _ RECIPIENTS NSPSTART _ HEADEREOF NSPFIELDS _ INTERESTINGFIELDS NSPFORMATTED _ FORMATTEDP))))
)

(\NSMAIL.CHECK.ENUMERATION
(LAMBDA (PAIR EDITORWINDOW) (* ; "Edited 24-Jan-90 16:35 by bvm") (LET* ((FIELD (CAR PAIR)) (VALUE (CADR PAIR)) (EXPECTED (CADDR (ASSOC FIELD \NSMAIL.HEADING.ATTRIBUTES))) FOUND) (if (EQ (CAR (LISTP EXPECTED)) (QUOTE ENUMERATION)) then (SETQ EXPECTED (CDR EXPECTED)) (if (SETQ FOUND (CL:ASSOC VALUE EXPECTED :TEST (QUOTE STRING-EQUAL))) then (CONS FIELD (CAR FOUND)) else (\SENDMESSAGEFAIL EDITORWINDOW (CL:FORMAT NIL "Field '~A' not understood--expected one of ~A" FIELD (CONCATLIST (CDR (for V in EXPECTED join (LIST ", " (CAR V)))))))) elseif (OR (STRING-EQUAL VALUE "True") (STRING-EQUAL VALUE "Yes") (STRING-EQUAL VALUE T)) then (* ; "Good.  Value is actually irrelevant") PAIR elseif (OR (STRING-EQUAL VALUE "False") (STRING-EQUAL VALUE "No")) then (* ; "Good, omit attribute") NIL else (\SENDMESSAGEFAIL EDITORWINDOW "Field 'Immutable' not understood--expected True or False"))))
)

(\NSMAIL.NEW.SEND
(LAMBDA (MSG PARSE EDITORWINDOW ABORTWINDOW) (* ; "Edited 29-Jun-90 16:04 by bvm") (* ;;; "MSG is the entire text of the message -- RECIPIENTS is a parsed list of recipients") (if (NOT *USE-NEW-NSMAIL*) then (\NSMAIL.SEND MSG PARSE EDITORWINDOW ABORTWINDOW) else (RESETLST (PROG* ((PWINDOW (AND EDITORWINDOW (GETPROMPTWINDOW EDITORWINDOW))) (RECIPIENTS (fetch NSPRECIPIENTS of PARSE)) (START (OR (fetch NSPSTART of PARSE) (GETEOFPTR MSG))) (MSGFIELDS (fetch NSPFIELDS of PARSE)) (CREDENTIALS (fetch (LAFITEMODEDATA CREDENTIALS) of *LAFITE-MODE-DATA*)) (ALLOW.DL.RECIPIENTS (OR *NSMAIL-ALLOW-DL-RECIPIENTS* (ASSOC (QUOTE Reply-to) MSGFIELDS))) USENSTEXTFILE FORMATSTREAM REFERENCE ATTACHMENT ATTACHMENT-TYPE ATTACHMENT-LENGTH ATTACHED-ATTRIBUTES BODYLENGTH COURIERSTREAM MAILDROP RESULTS HEADING SESSION ESTIMATED-SIZE PART-TYPES) (* ;; "Some day maybe try using the ALLOW.DL.RECIPIENTS feature.  Unfortunately, there are too many users in XNS who look like groups to the mail system for this to be very interesting.") (COND (PWINDOW (* ; "Make sure prompt window will expand as needed.  Probably generic sendmessage should do this") (RESETSAVE (TTYDISPLAYSTREAM PWINDOW)) (RESETSAVE (LINELENGTH T)))) (COND ((AND (fetch NSPFORMATTED of PARSE) (TEDIT.FORMATTEDFILEP MSG)) (* ; "Message is formatted, so get info.  Have to exclude header, since it is not sent.") (SETQ MSG (COPYTEXTSTREAM MSG)) (TEDIT.DELETE MSG 1 START) (SETQ FORMATSTREAM (COERCETEXTOBJ MSG (QUOTE SPLIT))) (* ; "Get (body  . formatting)") (CLOSEF MSG) (* ; "We're thru with this new textstream, let it clean up after itself.") (SETQ MSG (OPENSTREAM (CAR FORMATSTREAM) (QUOTE INPUT))) (SETQ FORMATSTREAM (OPENSTREAM (CDR FORMATSTREAM) (QUOTE INPUT))) (SETQ START 0)) ((AND (TEXTSTREAMP MSG) (TEDIT.FORMATTEDFILEP MSG)) (* ; "Message has formatting, but caller asked to send it as plain text.  Carefully coerce it, since TEDIT ns chars and image objects don't pass thru COPYBYTES very well") (SETQ MSG (LAFITE.MAKE.PLAIN.TEXTSTREAM MSG START)) (SETQ START 0))) (SETQ BODYLENGTH (- (GETEOFPTR MSG) START)) (if FORMATSTREAM then (* ; "Formatted messages can only go as text files for now, or else old clients can't receive them") (SETQ USENSTEXTFILE T) else (CASE *NEWNSMAIL-POST-AS-TEXTFILE* ((NIL) (* ; "Always send as note")) ((:TEST) (* ; "Send as note only if short enough (the default)") (if (> BODYLENGTH *NSMAIL-MAX-NOTE-LENGTH*) then (SETQ USENSTEXTFILE T))) (T (SETQ USENSTEXTFILE T)))) (SETQ REFERENCE (ASSOC (QUOTE REFERENCE) MSGFIELDS)) (SETQ ATTACHMENT (ASSOC (QUOTE ATTACHMENT) MSGFIELDS)) (if (OR REFERENCE ATTACHMENT) then (if ATTACHMENT then (* ; "We're going to send a whole file along with the message") (SETQ MSGFIELDS (DREMOVE ATTACHMENT MSGFIELDS)) (if (LISTP (SETQ ATTACHMENT (\NSMAIL.NEW.PREPARE.ATTACHMENT (CADR ATTACHMENT) EDITORWINDOW))) then (* ; "Not an ns file") (SETQ ATTACHMENT-TYPE (CDR (ASSOC (QUOTE BodyType) (SETQ ATTACHED-ATTRIBUTES (CDR ATTACHMENT))))) (SETQ ATTACHMENT (CAR ATTACHMENT)) (* ; "Length estimate: file length.  Actual length will be a little greater due to attributes.") (SETQ ATTACHMENT-LENGTH (GETEOFPTR ATTACHMENT)) else (* ; "NS serialized file") (SETQ ATTACHMENT-TYPE (GETFILEINFO ATTACHMENT (QUOTE FILETYPE))) (* ;; "To estimate length, ask server for stored size.  This is rounded up to nearest page, so we subtract lest we overestimate (grumble).  In directory case, it could be way off, though, due to rounding errors from lots of files.  It's either that or read the whole damn file into core.") (SETQ ATTACHMENT-LENGTH (- (GETFILEINFO ATTACHMENT (if (GETFILEINFO ATTACHMENT (QUOTE IS.DIRECTORY)) then (QUOTE SUBTREE.SIZE) else (QUOTE STORED.SIZE))) BYTESPERPAGE))) (SETQ ATTACHMENT-TYPE (CASE (\TYPE.FROM.FILETYPE ATTACHMENT-TYPE) (INTERPRESS (if NIL then (* ; "This way doesn't go thru the backward incompatibility module correctly.") (\NSMAIL.BODY.PART.TYPE INTERPRESS) else (\NSMAIL.BODY.PART.TYPE VPDOCUMENT))) (DIRECTORY (\NSMAIL.BODY.PART.TYPE VPFOLDER)) (TEXT (\NSMAIL.BODY.PART.TYPE NSTEXTFILE)) (T (if (AND (>= ATTACHMENT-TYPE \NSMAIL.MIN.VP.TYPE) (<= ATTACHMENT-TYPE \NSMAIL.MAX.VP.TYPE)) then (* ; "I assume everything in this range is a vpdocument") (\NSMAIL.BODY.PART.TYPE VPDOCUMENT) else (\NSMAIL.BODY.PART.TYPE OTHERNSFILE))))) elseif REFERENCE then (* ; "Just a Vp reference.  This is a null file with a special attribute giving the file name, etc") (SETQ MSGFIELDS (DREMOVE REFERENCE MSGFIELDS)) (SETQ ATTACHED-ATTRIBUTES (LIST (CONSTANT (CONS (QUOTE BodyType) \NSMAIL.REFERENCE.BODYTYPE)) (RPLACD REFERENCE (\NSMAIL.PARSE.REFERENCE (CADR REFERENCE) EDITORWINDOW)))) (SETQ ATTACHMENT-TYPE (\NSMAIL.BODY.PART.TYPE VPDOCUMENT))) (SETQ PART-TYPES (LIST ATTACHMENT-TYPE))) (if USENSTEXTFILE then (push PART-TYPES (\NSMAIL.BODY.PART.TYPE NSTEXTFILE)) elseif (> BODYLENGTH 0) then (push PART-TYPES (\NSMAIL.BODY.PART.TYPE MULTINATIONAL.NOTE))) (SETQ HEADING (\NSMAIL.BUILD.HEADING MSGFIELDS (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) (SETQ RECIPIENTS (for R in RECIPIENTS as I from 1 collect (COURIER.CREATE (NEW.MAILTRANSPORT . RECIPIENT) NAME _ R RECIPIENT.ID _ I REPORT _ (OR *NEWNSMAIL-REPORT-TYPE* (QUOTE NON.DELIVERY.ONLY))))) (COND (PWINDOW (CLEARW PWINDOW) (LET ((TYPE (if REFERENCE then (\TYPE.FROM.FILETYPE (CADR (ASSOC (QUOTE TYPE) (CDR REFERENCE)))) elseif ATTACHMENT-TYPE then (for PAIR in \NSMAIL.BODY.PART.TYPES when (EQL ATTACHMENT-TYPE (CADR PAIR)) do (RETURN (CAR PAIR)))))) (CL:FORMAT PWINDOW "Delivering ~:[~;formatted ~]~@[with ~A ~]~@[~A ~]to ~D recipient~:P" FORMATSTREAM (AND TYPE (CL:STRING-CAPITALIZE (MKSTRING TYPE))) (COND (REFERENCE "reference") (ATTACHMENT "attachment")) (LENGTH RECIPIENTS))))) (SETQ ESTIMATED-SIZE (PROGN (* ;; "@##!@ protocol demands that you tell the size of the message almost exactly.  Specifically, size estimate must not be too large (!), and not be more than 5000 bytes too small.  That almost means you have to buffer the whole message before you start.  We are lazy here and hope that serialization overhead and file server size estimates don't screw us up.") (+ (GETEOFPTR HEADING) BODYLENGTH (if FORMATSTREAM then (* ; "This plus a few more bytes of serialized file encoding") (GETEOFPTR FORMATSTREAM) else 0) (OR ATTACHMENT-LENGTH 0)))) (COND ((NULL (SETQ MAILDROP (\NSMAIL.NEW.FINDSERVER ESTIMATED-SIZE))) (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't find a mail drop")))) (to 3 until (SETQ COURIERSTREAM (COURIER.OPEN MAILDROP NIL T (QUOTE NSMAILER))) do (* ; "loop 3 times trying to start this send") (DISMISS 1000)) (COND ((NULL COURIERSTREAM) (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't connect to a maildrop")))) (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) COURIERSTREAM)) (AND PWINDOW (printout PWINDOW (QUOTE |...|))) (SETQ RESULTS (COURIER.CALL COURIERSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE BEGIN.POST) (COURIER.CREATE (NEW.MAILTRANSPORT . POSTING.DATA) RECIPIENTS _ RECIPIENTS CONTENTS.TYPE _ \CT.STANDARD.MESSAGE CONTENTS.SIZE _ ESTIMATED-SIZE BODY.PART.TYPES.SEQUENCE _ (CONS (\NSMAIL.BODY.PART.TYPE HEADING) PART-TYPES)) NIL ALLOW.DL.RECIPIENTS (AND *NSMAIL-RETURN-CONTENTS* (QUOTE ((TRANSPORT.OPTIONS (T T))))) (CAR CREDENTIALS) (CDR CREDENTIALS) (QUOTE RETURNERRORS))) (COND ((EQ (CAR (LISTP RESULTS)) (QUOTE ERROR)) (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW (SELECTQ (CADR RESULTS) (INVALID.RECIPIENTS (\NSMAIL.NEW.INVALID.RECIPIENTS (CADDR RESULTS) RECIPIENTS)) (MKSTRING (CDR RESULTS))))))) (* ;; "RESULTS = (session invalid-recipients)") (SETQ SESSION (CAR RESULTS)) (if (SETQ RESULTS (CADR RESULTS)) then (* ; "Some were invalid.  I think we don't get any here because we didn't say to post anyway.") (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW (\NSMAIL.NEW.INVALID.RECIPIENTS RESULTS RECIPIENTS)))) (* ;; "Now post body parts") (\NSMAIL.CHECK.ABORT ABORTWINDOW COURIERSTREAM SESSION) (\NSMAIL.POST.BODY.PART COURIERSTREAM SESSION (\NSMAIL.BODY.PART.TYPE HEADING) HEADING 0 EDITORWINDOW) (\NSMAIL.CHECK.ABORT ABORTWINDOW COURIERSTREAM SESSION) (if USENSTEXTFILE then (\NSMAIL.POST.BODY.PART COURIERSTREAM SESSION (\NSMAIL.BODY.PART.TYPE NSTEXTFILE) MSG START EDITORWINDOW (BQUOTE ((BodyType (\,@ \NSMAIL.TEXT.BODYTYPE)) (\,@ (AND FORMATSTREAM (BQUOTE ((LispFormatting (\,@ FORMATSTREAM))))))))) elseif (> BODYLENGTH 0) then (\NSMAIL.POST.BODY.PART COURIERSTREAM SESSION (\NSMAIL.BODY.PART.TYPE MULTINATIONAL.NOTE) MSG START EDITORWINDOW)) (\NSMAIL.CHECK.ABORT ABORTWINDOW COURIERSTREAM SESSION) (if ATTACHMENT-TYPE then (\NSMAIL.POST.BODY.PART COURIERSTREAM SESSION ATTACHMENT-TYPE ATTACHMENT NIL EDITORWINDOW ATTACHED-ATTRIBUTES) (\NSMAIL.CHECK.ABORT ABORTWINDOW COURIERSTREAM SESSION)) (if ABORTWINDOW then (* ; "Too late to abort now") (DELETEMENU (CAR (WINDOWPROP ABORTWINDOW (QUOTE MENU))) NIL ABORTWINDOW)) (SETQ RESULTS (COURIER.CALL COURIERSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE END.POST) SESSION NIL (QUOTE RETURNERRORS))) (if (EQ (CAR (LISTP RESULTS)) (QUOTE ERROR)) then (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW (MKSTRING (CDR RESULTS))))) (AND NSMAILDEBUGFLG (printout PROMPTWINDOW T "EndPost results: " RESULTS)) (RETURN (LENGTH RECIPIENTS))))))
)

(\NSMAIL.NEW.INVALID.RECIPIENTS
(LAMBDA (INVALID.NAME.LIST RECIPIENTS) (* ; "Edited 19-Dec-89 13:00 by bvm") (* ;; "INVALID.NAME.LIST = Sequence (id reason).  id is 1-based.") (if (CDR INVALID.NAME.LIST) then (CONCAT "Invalid recipients: " (SUBSTRING (for PAIR in INVALID.NAME.LIST collect (LIST (COURIER.FETCH (NEW.MAILTRANSPORT . RECIPIENT) NAME of (CAR (NTH RECIPIENTS (CAR PAIR)))) (CADR PAIR))) 2 -2)) else (DESTRUCTURING-BIND (ID REASON) (CAR INVALID.NAME.LIST) (CONCAT (COURIER.FETCH (NEW.MAILTRANSPORT . RECIPIENT) NAME of (CAR (NTH RECIPIENTS ID))) " -- " REASON))))
)

(\NSMAIL.BUILD.HEADING
(LAMBDA (MSGFIELDS SENDER) (* ; "Edited 11-Jul-90 18:03 by bvm") (* ;; "Build a heading body part, which is a sequence of attribute.  Return a stream") (LET ((S (OPENSTREAM "{nodircore}" (QUOTE BOTH))) (COUNT 2)) (SETFILEPTR S 2) (* ; "Save space for the sequence count") (COND ((ASSOC (QUOTE From) MSGFIELDS) (* ; "Identify actual sender (single name here)") (\NS.WRITE.HEADING.ATTRIBUTE S (LIST (QUOTE Sender) SENDER) (QUOTE NEW.MAILTRANSPORT))) (T (* ; "Identify sender as the sole %"From%" name") (\NS.WRITE.HEADING.ATTRIBUTE S (LIST (QUOTE From) (LIST SENDER)) (QUOTE NEW.MAILTRANSPORT)))) (for PAIR in MSGFIELDS do (\NS.WRITE.HEADING.ATTRIBUTE S (LIST (CAR PAIR) (CDR PAIR)) (QUOTE NEW.MAILTRANSPORT)) (add COUNT 1)) (\NS.WRITE.HEADING.ATTRIBUTE S (LIST (QUOTE TextAnnotation) (CONCAT "Date: " (DATE (DATEFORMAT TIME.ZONE SPACES DAY.OF.WEEK)) LAFITEEOL)) (QUOTE NEW.MAILTRANSPORT)) (* ; "Send the Date with time zone, as Cedar does") (if *NSMAIL-GENERATE-MESSAGE-ID* then (\NS.WRITE.HEADING.ATTRIBUTE S (LIST (QUOTE Message-ID) (COURIER.CREATE (NEW.MAILTRANSPORT . IP.MESSAGEID) ORIGINATOR _ (fetch UNPACKEDUSERNAME of *LAFITE-MODE-DATA*) UNIQUESTRING _ (DATE (DATEFORMAT TIME.ZONE)))) (QUOTE NEW.MAILTRANSPORT)) (add COUNT 1)) (SETFILEPTR S 0) (\WOUT S COUNT) S))
)

(\NSMAIL.POST.BODY.PART
(LAMBDA (COURIERSTREAM SESSION TYPE PARTSTREAM START EDITORWINDOW ATTRIBUTES) (* ; "Edited  8-Mar-90 12:14 by bvm") (LET ((RESULTS (COURIER.CALL COURIERSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE POST.ONE.BODY.PART) SESSION TYPE (FUNCTION (LAMBDA (BULKSTREAM) (if ATTRIBUTES then (* ; "Create a serialized file on the fly") (COURIER.WRITE BULKSTREAM \SERIALIZED.FILE.VERSION NIL (QUOTE LONGCARDINAL)) (* ; "version.  Next comes Sequence Attribute") (\WOUT BULKSTREAM (LENGTH ATTRIBUTES)) (for PAIR in ATTRIBUTES do (if (EQ (CAR PAIR) (QUOTE LispFormatting)) then (* ; "Do this special so we don't have to cons an enormous string") (\NSMAIL.SEND.STREAM.AS.STRING (CDR PAIR) BULKSTREAM 0 (\NSMAIL.ATTRIBUTE.TYPE LispFormatting)) else (\NSMAIL.WRITE.ATTRIBUTE BULKSTREAM (CAR PAIR) (CDR PAIR)))) (* ;; "Next comes StreamOfUnspecified, then lastByteIsSignificant") (if PARTSTREAM then (COURIER.WRITE BULKSTREAM (COURIER.WRITE.STREAM.UNSPECIFIED BULKSTREAM PARTSTREAM (OR START 0) -1) NIL (QUOTE BOOLEAN)) else (* ; "no content") (\WOUT BULKSTREAM 1) (* ; "Last segment") (\WOUT BULKSTREAM 0) (* ; "Empty sequence") (\WOUT BULKSTREAM 1) (* ; "Last Byte is Significant = Byte Length is Even.")) (\WOUT BULKSTREAM 0) (* ; "no children") else (* ; "PARTSTREAM is already in proper format, just send it") (if START then (SETFILEPTR PARTSTREAM START)) (COPYBYTES PARTSTREAM BULKSTREAM)) (* ; "return NIL so caller can see return value") NIL)) (QUOTE RETURNERRORS)))) (if (EQ (CAR RESULTS) (QUOTE ERROR)) then (COURIER.CALL COURIERSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE END.POST) SESSION T (QUOTE RETURNERRORS)) (* ; "Abort the post") (\LAFITE.SEND.FAIL EDITORWINDOW (CL:FORMAT NIL "Failed to post ~A because: ~A" (CAR (find TYP in \NSMAIL.BODY.PART.TYPES suchthat (EQ (CADR TYP) TYPE))) (CDR RESULTS))) (ERROR!))))
)

(\NSMAIL.NEW.PREPARE.ATTACHMENT
(LAMBDA (FILE EDITORWINDOW) (* ; "Edited 19-Dec-89 11:38 by bvm") (LET* ((HOST (UNPACKFILENAME.STRING FILE (QUOTE HOST))) (SERIALIZED (STRPOS ":" HOST)) BODYTYPE) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (if SERIALIZED then (\NSFILING.GETFILE (\GETDEVICEFROMHOSTNAME (MKATOM (U-CASE HOST))) FILE (QUOTE SERIALIZE) (QUOTE OLD) NIL NIL T) else (OPENSTREAM FILE (QUOTE INPUT)))) (if (NULL STREAM) then (\LAFITE.SEND.FAIL EDITORWINDOW (OR CONDITION "Attachment not found.")) (ERROR!)) (RESETSAVE NIL (LIST (FUNCTION CLOSEF) STREAM)) (if SERIALIZED then (* ; "Easy case") STREAM else (* ; "Not on an NS server, let's investigate the type") (CASE (SETQ BODYTYPE (\FILETYPE.FROM.TYPE (GETFILEINFO STREAM (QUOTE TYPE)))) ((NIL 0) (* ; "Under specified") (if (SETQ BODYTYPE (\NSMAIL.GUESS.FILE.TYPE (FULLNAME STREAM))) then (SETQ BODYTYPE (\FILETYPE.FROM.TYPE BODYTYPE)) elseif (\SENDMESSAGE.MENUPROMPT EDITORWINDOW (\LAFITE.CREATE.MENU (QUOTE (("Send as BINARY attachment" T) ("Abort" NIL))) "Send attachment?") "Warning: Type of attached file is unknown; most mail clients can't do anything interesting with this.") then (SETQ BODYTYPE 0) else (ERROR!)))) (CONS STREAM (BQUOTE ((BodyType (\,@ BODYTYPE)) (MODIFIED.ON (\,@ (GETFILEINFO STREAM (QUOTE ICREATIONDATE)))))))))))
)

(\NSMAIL.CHECK.ABORT
(LAMBDA (ABORTWINDOW COURIERSTREAM SESSION) (* ; "Edited 28-Nov-89 15:06 by bvm") (* ;; "Abort a post if user has pressed Abort") (COND ((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW (QUOTE ABORT))) (* ; "Abort the post") (COURIER.CALL COURIERSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE END.POST) SESSION T (QUOTE RETURNERRORS)) (ERROR!))))
)

(\NSMAIL.NEW.FINDSERVER
(LAMBDA (ESTIMATED-SIZE) (* ; "Edited 25-Jun-90 16:02 by bvm") (PROG (INFO) (if (AND (CDR \NSMAIL.NEW.SERVER.CACHE) (NOT (TIMEREXPIRED? (CAR \NSMAIL.NEW.SERVER.CACHE)))) then (if (SETQ INFO (find ADDR in (CDR \NSMAIL.NEW.SERVER.CACHE) suchthat (\NSMAIL.NEW.CHECKSERVER (COURIER.EXPEDITED.CALL ADDR \NSMAIL.SOCKET (QUOTE NEW.MAILTRANSPORT) (QUOTE SERVER.POLL) (QUOTE RETURNERRORS)) ESTIMATED-SIZE))) then (RETURN INFO)) else (* ;; "Cache nonexistent or timed out, so refigure from scratch.  We like to time out the cache periodically so that we don't permanently latch on to some distant server when local ones are flaky.") (SETQ \NSMAIL.NEW.SERVER.CACHE (LIST (SETUPTIMER *NSMAIL-CACHE-TIMEOUT* (CAR \NSMAIL.NEW.SERVER.CACHE))))) (* ;; "Ask around for a server") (COND ((SETQ INFO (COURIER.BROADCAST.CALL \NSMAIL.SOCKET (QUOTE NEW.MAILTRANSPORT) (QUOTE SERVER.POLL) NIL (FUNCTION (LAMBDA (RESULT) (\NSMAIL.NEW.CHECKSERVER RESULT ESTIMATED-SIZE))) NSMAIL.NET.HINT)) (push (CDR \NSMAIL.NEW.SERVER.CACHE) INFO))) (RETURN INFO)))
)

(\NSMAIL.NEW.CHECKSERVER
(LAMBDA (POLLRESULT ESTIMATED-SIZE) (* ; "Edited 29-Jun-90 17:57 by bvm") (* ;; "Checks that the result of a SERVER.POLL is useful for sending a message of size ESTIMATED-SIZE.  Returns the server's address") (* ;; "POLLRESULT = (willingness network.address.list name)") (LET ((WILLINGNESS (CAR POLLRESULT)) (SIZE (OR ESTIMATED-SIZE 4000))) (* ; "The i'th element of willingness defines the server's willingness to accept messages up to size 8^i.") (if (AND (LISTP WILLINGNESS) (for W in WILLINGNESS as (I _ 8) by (LLSH I 3) while (> I SIZE) always (>= W *NSMAIL-MIN-WILLINGNESS*))) then (PROG ((BESTADDRESS (CAR (SORT.NSADDRESSES.BY.DISTANCE (CADR POLLRESULT))))) (SELECTQ *NSMAIL-TRACE-SERVERS* (NIL NIL) (:ASK (if (NOT (EQ (QUOTE Y) (ASKUSER 30 (QUOTE Y) (LIST "Use posting server" (CADDR POLLRESULT) (LIST BESTADDRESS)) NIL T))) then (RETURN NIL))) (PRINTOUT PROMPTWINDOW T "Using posting server " (CADDR POLLRESULT) " = " BESTADDRESS)) (RETURN BESTADDRESS)))))
)
)

(RPAQQ NSMAIL.PARSEFIELDS (("DATE:" LAFITE.READ.LINE.FOR.TOC Date) ("SUBJECT:" LAFITE.READ.LINE.FOR.TOC Subject) ("SENDER:" LAFITE.READ.NAME.FIELD Sender) ("FROM:" LAFITE.READ.NAME.FIELD From) ("REPLY-TO:" LAFITE.READ.NAME.FIELD Reply-to) ("IN-REPLY-TO:" LAFITE.READ.LINE.FOR.TOC In-Reply-to) ("TO:" LAFITE.READ.NAME.FIELD To) ("CC:" LAFITE.READ.NAME.FIELD cc) ("FORMAT:" LAFITE.READ.FORMAT) ("ATTACHED-REFERENCE:" LAFITE.READ.LINE.FOR.TOC REFERENCE) ("ATTACHED-FILE:" LAFITE.READ.LINE.FOR.TOC ATTACHMENT) ("Importance:" LAFITE.READ.LINE.FOR.TOC Importance) ("Sensitivity:" LAFITE.READ.LINE.FOR.TOC Sensitivity) ("Immutable:" LAFITE.READ.LINE.FOR.TOC Immutable)))

(RPAQ \LAPARSE.NSMAIL (LAFITE.MAKE.PARSE.TABLE NSMAIL.PARSEFIELDS))
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(AND (CCODEP (QUOTE \NSMAIL.NEW.SEND.PARSE)) (MOVD (QUOTE \NSMAIL.NEW.SEND.PARSE) (QUOTE \NSMAIL.SEND.PARSE) NIL T))
)

(RPAQ? *USE-NEW-NSMAIL* T)

(RPAQ? *NEWNSMAIL-POST-AS-TEXTFILE* :TEST)

(RPAQ? *NEWNSMAIL-REPORT-TYPE* (QUOTE NON.DELIVERY.ONLY))

(RPAQ? *NSMAIL-ALLOW-DL-RECIPIENTS* T)

(RPAQ? *NSMAIL-RETURN-CONTENTS* T)

(RPAQ? *NSMAIL-MIN-WILLINGNESS* 9)

(RPAQ? *NSMAIL-TRACE-SERVERS*)

(RPAQ? *NSMAIL-GENERATE-MESSAGE-ID*)

(RPAQ? *NSMAIL-DISPLAY-TRANSPORT-ID*)

(RPAQ? *NSMAIL-DISPLAY-POSTMARK*)

(RPAQ? *NSMAIL-DISPLAY-ERRORS-TO*)

(RPAQ? *NSMAIL-CACHE-TIMEOUT* (TIMES 1000 60 60))

(RPAQ? \NSMAIL.MIN.VP.TYPE 4300)

(RPAQ? \NSMAIL.MAX.VP.TYPE 5200)

(RPAQ? \NSMAIL.NEW.SERVER.CACHE)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \NSMAIL.NEW.SERVER.CACHE \NSMAIL.MIN.VP.TYPE \NSMAIL.MAX.VP.TYPE)
)

(CL:PROCLAIM (QUOTE (CL:SPECIAL *USE-NEW-NSMAIL* *NEWNSMAIL-POST-AS-TEXTFILE* *NEWNSMAIL-REPORT-TYPE* *NSMAIL-ALLOW-DL-RECIPIENTS* *NSMAIL-RETURN-CONTENTS* *NSMAIL-MIN-WILLINGNESS* *NSMAIL-TRACE-SERVERS* *NSMAIL-GENERATE-MESSAGE-ID* *NSMAIL-DISPLAY-TRANSPORT-ID* *NSMAIL-DISPLAY-POSTMARK* *NSMAIL-DISPLAY-ERRORS-TO* *NSMAIL-CACHE-TIMEOUT*)))



(* ; "Retrieving")

(DEFINEQ

(\NSMAIL.NEW.AUTHENTICATE
(LAMBDA NIL (* ; "Edited  4-Apr-90 17:26 by bvm") (LET ((INFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|))) NSUSERNAME FULLNAME MSERVERS AUTHENTICATED? CREDENTIALS MSG) (SETQ NSUSERNAME (PARSE.NSNAME (CAR INFO))) (COND ((NEQ (SETQ AUTHENTICATED? (COND ((NULL (SETQ FULLNAME (CH.LOOKUP.OBJECT NSUSERNAME))) (QUOTE NONE)) (T (NS.AUTHENTICATE (SETQ CREDENTIALS (NS.MAKE.SIMPLE.CREDENTIALS (CONS FULLNAME (CDR INFO)))))))) T) (printout PROMPTWINDOW T "Cannot authenticate user " (RNAME.TO.STRING (OR FULLNAME NSUSERNAME) T) " because: " (SELECTQ (SETQ \LAFITE.AUTHENTICATION.FAILURE AUTHENTICATED?) (CredentialsInvalid "Login incorrect") (KeysUnavailable (CONCAT "Authentication server unavailable for domain " (fetch NSDOMAIN of FULLNAME))) (NONE "No such user") AUTHENTICATED?) ".") NIL) (T (create LAFITEMODEDATA FULLUSERNAME _ (RNAME.TO.STRING FULLNAME T) UNPACKEDUSERNAME _ FULLNAME CREDENTIALS _ CREDENTIALS SHORTUSERNAME _ (CONCAT (fetch NSOBJECT of FULLNAME) (QUOTE %:) (COND ((NOT (STRING-EQUAL (fetch NSDOMAIN of FULLNAME) CH.DEFAULT.DOMAIN)) (fetch NSDOMAIN of FULLNAME)) (T ""))) MAILSERVERS _ (LET ((SERVERS (\NSMAIL.MAKE.MAILSERVERS (NS.FINDMAILBOXES FULLNAME) FULLNAME CREDENTIALS))) (if *USE-NEW-NSMAIL* then (for S in SERVERS do (replace MAILSERVEROPS of S with (CONSTANT (LIST (FUNCTION NEWNS.POLLNEWMAIL) (FUNCTION NEWNS.OPENMAILBOX) (FUNCTION NEWNS.NEXTMESSAGE) (FUNCTION NEWNS.RETRIEVEMESSAGE) (FUNCTION NEWNS.CLOSEMAILBOX)))))) SERVERS))))))
)

(NEWNS.POLLNEWMAIL
(LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER) (* ; "Edited 18-Dec-89 18:59 by bvm") (LET ((RESULT (\NSMAIL.NEW.CHECK ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER))) (COND ((OR (NOT RESULT) (EQ (CAR RESULT) (QUOTE ERROR))) (* ; "Server down") (QUOTE ?)) ((NEQ RESULT 0) RESULT))))
)

(NEWNS.OPENMAILBOX
(LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER) (* ; "Edited 18-Dec-89 18:59 by bvm") (LET ((STREAM (\NSMAIL.COURIER.OPEN ADDRESS)) NSMAILSTATE N) (COND ((NULL STREAM) NIL) ((OR (NULL (SETQ N (\NSMAIL.NEW.CHECK ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER STREAM T))) (EQ (CAR N) (QUOTE ERROR))) (CLOSEF STREAM) (* ; "Return error msg") (CONS NIL (CDR N))) ((EQ (PROGN (SETQ NSMAILSTATE (fetch MAILSTATE of MAILSERVER)) N) 0) (\NSMAIL.NEW.LOGOFF NSMAILSTATE STREAM) (QUOTE EMPTY)) (T (* ; "Return (MAILBOX  . properties)") (CONS (create NSMAILBOX NSMAILSTREAM _ STREAM NSMAILLASTINDEX _ 0 NSMAILSTATE _ NSMAILSTATE) (LIST (QUOTE %#OFMESSAGES) N))))))
)

(\NSMAIL.NEW.CHECK
(LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER STREAM RETURNERRORS) (* ; "Edited  5-Jan-90 19:21 by bvm") (* ;;; "Performs a mail check for user REGISTEREDNAME at ADDRESS, returning INBASKETSTATE if successful, NIL if not.  Updates the MAILSTATE of MAILSERVER as appropriate to reflect current SESSION and STATEFIRSTNEW (first new message)") (RESETLST (PROG ((JUSTCHECKING (NULL STREAM)) (STATE (fetch (MAILSERVER MAILSTATE) of MAILSERVER)) SESSION POLLRESULT TIMER) (COND ((AND NIL JUSTCHECKING (SETQ TIMER (fetch STATETIMER of STATE)) (TIMEREXPIRED? TIMER) (\NSMAIL.FIX.MAILBOX.LOCATIONS)) (* ; "Some mailboxes moved") (GO FAILFAST))) (SETQ SESSION (fetch STATESESSION of STATE)) RETRY (COND ((NULL SESSION) (if JUSTCHECKING then (* ; "Just polling, don't need session") (SETQ POLLRESULT (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET (QUOTE NEW.INBASKET) (QUOTE MAILPOLL) (fetch STATENAME of STATE) (CAR CREDENTIALS) (CDR CREDENTIALS) (QUOTE RETURNERRORS))) (GO GOTRESULT)) (COND ((NULL STREAM) (* ; "Need a real Courier stream for some reason here") (COND ((SETQ STREAM (COURIER.OPEN ADDRESS NIL T (QUOTE NSMAIL))) (RESETSAVE NIL (LIST (QUOTE CLOSEF) STREAM))) (T (RETURN NIL))))) (COND ((EQ (CAR (SETQ SESSION (COURIER.CALL STREAM (QUOTE NEW.INBASKET) (QUOTE LOGON) (fetch STATENAME of STATE) (CAR CREDENTIALS) (CDR CREDENTIALS) (QUOTE RETURNERRORS)))) (QUOTE ERROR)) (GO ERROR))) (* ; "result = (session state anchor)") (SETQ POLLRESULT (CADR SESSION)) (replace STATESESSION of STATE with (SETQ SESSION (CAR SESSION)))) (T (SETQ POLLRESULT (COND ((NULL STREAM) (* ; "Just checking") (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET (QUOTE NEW.INBASKET) (QUOTE MAILCHECK) SESSION (QUOTE RETURNERRORS))) (T (COURIER.CALL STREAM (QUOTE NEW.INBASKET) (QUOTE MAILCHECK) SESSION (QUOTE RETURNERRORS))))))) GOTRESULT (COND ((NULL POLLRESULT) (* ; "Failed somehow") (RETURN NIL)) ((EQ (CAR (LISTP POLLRESULT)) (QUOTE ERROR)) (COND ((EQ (CADR POLLRESULT) (QUOTE SESSION.ERROR)) (* ; "Session timed out, start a new one") (replace STATESESSION of STATE with (SETQ SESSION NIL)) (replace STATEFIRSTNEW of STATE with NIL) (replace STATEOLDLAST of STATE with NIL) (GO RETRY)) (T (SETQ SESSION POLLRESULT) (GO ERROR))))) (replace STATELASTERROR of STATE with NIL) (replace (MAILSERVER CONTINUANCE) of MAILSERVER with NIL) (RETURN (COURIER.FETCH (NEW.INBASKET . STATE) TOTAL of POLLRESULT)) ERROR (if (AND (NOT (EQUAL (CDR SESSION) (QUOTE (CONNECTION.PROBLEM NoResponse)))) (NOT (EQUAL (CDR SESSION) (fetch STATELASTERROR of STATE)))) then (* ;; "Don't bother mentioning the error if it's just a timeout, since mailwatch will handle our NIL response fine.  Also don't repeatedly print the same error message.") (replace STATELASTERROR of STATE with (CDR SESSION)) (LET ((ERRMSG (CASE (CADR SESSION) ((REJECT) (* ; "3rd element = reject reason") (LET* ((REASON (CADDR SESSION)) (TYPE (CAR REASON))) (if (AND (EQ TYPE (QUOTE WrongVersionOfService)) (<= (CAADR REASON) 1) (< (CADADR REASON) 2)) then (* ; "Server supports old inbasket, but not new") (PRINTOUT PROMPTWINDOW T T "****Note: " (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER) " does not support new mail protocols." T "Setting *USE-NEW-NSMAIL* to NIL and trying again...") (SETQ *USE-NEW-NSMAIL* NIL) (SETQ \LAFITE.ACTIVE.MODES NIL) (LET ((POS (STKPOS (QUOTE POLLNEWMAIL)))) (if POS then (* ; "Tell mail watcher to start over") (RETFROM POS 0 T))) (if (NOT RETURNERRORS) then (RETURN NIL))) TYPE)) ((SERVICE.ERROR ACCESS.ERROR) (* ; "the specific reason is just as informative, and more readable than the whole error.") (CADDR SESSION)) (T (COND (NSWIZARDFLG (HELP SESSION))) (SUBSTRING (CDR SESSION) 2 -2))))) (if RETURNERRORS then (RETURN (CONS (QUOTE ERROR) ERRMSG)) elseif (AND (EQ ERRMSG (QUOTE NoSuchInbasket)) (\NSMAIL.FIX.MAILBOX.LOCATIONS)) then (* ;; "We get this when the server no longer holds this inbox.  At this point we have fixed mail servers in NS mode, but there's no good way for us to report the news, so go ahead and return NIL, but set %"continuance%" so that poll will happen again immediately") (replace (MAILSERVER CONTINUANCE) of MAILSERVER with 0) else (LET ((*PRINT-CASE* :UPCASE)) (* ; "Lousy atomic error names...") (CL:FORMAT PROMPTWINDOW "~%%From mail server ~A: ~A" (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER) (CASE ERRMSG (NoSuchService "Mail service not running") (T ERRMSG))))))) FAILFAST (RETURN NIL))))
)

(NEWNS.NEXTMESSAGE
(LAMBDA (MAILBOX) (* ; "Edited 13-Dec-89 17:27 by bvm") (LET ((NEXT (NEW.INBASKET.CALL MAILBOX (QUOTE RETRIEVE.ENVELOPES) (fetch NSMAILLASTINDEX of MAILBOX) (QUOTE NEXT) (fetch NSMAILSESSION of MAILBOX)))) (* ;; "NEXT = (envelope status index)") (DESTRUCTURING-BIND (ENVELOPE STATUS INDEX) NEXT (if (EQ INDEX 0) then (* ; "No more messages") NIL else (replace NSMAILLASTINDEX of MAILBOX with INDEX) (replace NSMAILENVTAIL of MAILBOX with ENVELOPE) (* ; "Success") T))))
)

(NEWNS.RETRIEVEMESSAGE
(LAMBDA (MAILBOX MSGOUTFILE) (* ; "Edited 16-Jan-90 15:43 by bvm") (DECLARE (SPECVARS *ATTACHMENTS* *DISCARDED-PARTS* *ENVELOPE* *FORMAT-STREAM* *HAVE-ATTACHMENTS* *HEADER-EOF* *MSGSTREAM* *RETRIEVAL-ERROR* *TABLE-OF-CONTENTS*)) (* ; "For the bulk data fn") (PROG* ((*RETRIEVAL-ERROR* NIL) (INDEX (fetch NSMAILLASTINDEX of MAILBOX)) (*ENVELOPE* (fetch NSMAILENVTAIL of MAILBOX)) (*TABLE-OF-CONTENTS* (CADR (ASSOC (QUOTE TOC) *ENVELOPE*))) (*MSGSTREAM* MSGOUTFILE) (HERE 0) *DISCARDED-PARTS* *HAVE-ATTACHMENTS* *ATTACHMENTS* *FORMAT-STREAM* *HEADER-EOF* PARTS-TO-RETRIEVE RESULT REPORT) (for PAIR in *TABLE-OF-CONTENTS* bind OTHER do (if (FMEMB (CAR PAIR) \NSMAIL.GOOD.BODY.PARTS) then (* ; "we read this fine") elseif (SETQ OTHER (ASSOC (CAR PAIR) \NSMAIL.DISCARDABLE.BODY.PARTS)) then (push *DISCARDED-PARTS* OTHER) else (* ; "Will need to arrange for an attachment") (SETQ *HAVE-ATTACHMENTS* T))) (if (NOT *HAVE-ATTACHMENTS*) then (* ; "Write directly to MSGOUTFILE.  Note where we are in case we have to retry") (SETQ HERE (GETFILEPTR *MSGSTREAM*))) (if *DISCARDED-PARTS* then (* ; "Ordinarily we retrieve everything (PARTS-TO-RETRIEVE = NIL), but if there were parts we like to ignore, we can skip these.") (SETQ PARTS-TO-RETRIEVE (for PAIR in *TABLE-OF-CONTENTS* as INDEX from 0 collect INDEX unless (ASSOC (CAR PAIR) *DISCARDED-PARTS*)))) RETRY (if *HAVE-ATTACHMENTS* then (SETQ *MSGSTREAM* (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (if (SETQ REPORT (CADR (ASSOC (QUOTE REPORT) *ENVELOPE*))) then (* ; "This is a delivery report.  What a crufty way to represent it") (SETQ *ENVELOPE* (\NSMAIL.HANDLE.DELIVERY.REPORT *MSGSTREAM* REPORT *ENVELOPE*)) (if (NULL *TABLE-OF-CONTENTS*) then (* ; "No body, e.g., a bad dl member report") (GO FINISH) else (* ; "Some message parts will follow the report") (PRINTOUT *MSGSTREAM* T "- - - - - - - - -" T))) (if (NEQ (CAAR *TABLE-OF-CONTENTS*) (\NSMAIL.BODY.PART.TYPE HEADING)) then (HELP "First body part is not heading" *TABLE-OF-CONTENTS*)) (SETQ RESULT (COURIER.CALL (fetch NSMAILSTREAM of MAILBOX) (QUOTE NEW.INBASKET) (QUOTE RETRIEVE.BODY.PARTS) INDEX PARTS-TO-RETRIEVE (FUNCTION \NSMAIL.READ.BODY.PARTS) (fetch NSMAILSESSION of MAILBOX) (QUOTE RETURNERRORS))) (if (EQ (CAR (LISTP RESULT)) (QUOTE ERROR)) then (\NSMAIL.SIGNAL.ERROR RESULT MAILBOX (QUOTE NEW.INBASKET) (QUOTE RETRIEVE.BODY.PARTS)) (if *HAVE-ATTACHMENTS* then (SETQ *ATTACHMENTS* NIL) else (SETFILEPTR MSGOUTFILE HERE)) (SETQ *RETRIEVAL-ERROR* NIL) (GO RETRY)) (COND (*RETRIEVAL-ERROR* (printout *MSGSTREAM* T *RETRIEVAL-ERROR* T))) (if *FORMAT-STREAM* then (* ; "This is a TEdit formatted message") (LA.ADJUST.FORMATTING *FORMAT-STREAM* *MSGSTREAM* (- *HEADER-EOF* HERE))) (if *HAVE-ATTACHMENTS* then (SETQ *MSGSTREAM* (OPENTEXTSTREAM *MSGSTREAM* NIL NIL NIL (LIST (QUOTE FONT) LAFITEDISPLAYFONT))) (LET ((ATTACHPOINT (TEDIT.FIND *MSGSTREAM* "

Attachment: " 1))) (SETQ ATTACHPOINT (if ATTACHPOINT then (* ; "Insert object at end of this line") (+ ATTACHPOINT 14) else (* ; "Shouldn't happen") (+ (TEDIT.FIND *MSGSTREAM* "

" 1) 2))) (for AT in *ATTACHMENTS* do (LET (TYPE) (SETFILEPTR AT 4) (* ; "Skip the version number (LONGCARDINAL).  Next comes SEQUENCE Filing.Attribute") (* ; "unknown") (to (\WIN AT) bind X ATTR do (if (EQ (SETQ ATTR (COURIER.READ AT NIL (QUOTE LONGCARDINAL))) (\NSMAIL.ATTRIBUTE.TYPE BodyType)) then (\WIN AT) (SETQ TYPE (\TYPE.FROM.FILETYPE (COURIER.READ AT NIL (QUOTE LONGCARDINAL)))) else (COURIER.SKIP.SEQUENCE AT NIL (QUOTE UNSPECIFIED)))) (TEDIT.INSERT.OBJECT (\MAILOBJ.CREATE AT TYPE (GETFILEPTR AT)) *MSGSTREAM* ATTACHPOINT)))) (* ;; "Would like the following to be (COERCETEXTOBJ OUTSTREAM 'FILE MSGOUTFILE) but Tedit has a bug") (COPYBYTES (OPENSTREAM (COERCETEXTOBJ *MSGSTREAM* (QUOTE FILE)) (QUOTE INPUT)) MSGOUTFILE)) FINISH (push (fetch NSMAILENVELOPES of MAILBOX) INDEX)))
)

(\NSMAIL.READ.BODY.PARTS
(LAMBDA (BULKSTREAM) (* ; "Edited 14-Aug-90 16:13 by bvm") (DECLARE (SPECVARS *ATTACHMENTS* *DISCARDED-PARTS* *ENVELOPE* *FORMAT-STREAM* *HAVE-ATTACHMENTS* *HEADER-EOF* *MSGSTREAM* *TABLE-OF-CONTENTS* *BODY-OFFSET*)) (* ;; "Bulk data handler for RetrieveBodyParts call.  We see the body parts, one directly after the other, per toc.") (* ;; "I hope the heading part is first") (for PAIR in *TABLE-OF-CONTENTS* as INDEX from 0 bind (START _ (GETFILEPTR BULKSTREAM)) (*BODY-OFFSET* _ 0) END HAVETEXT DISCARDING HEADERFIELDS FORWARDINFO FINFO FORWARDSTREAM PART-TYPE PART-LENGTH unless (ASSOC (SETQ PART-TYPE (CAR PAIR)) *DISCARDED-PARTS*) do (* ;; "Assertion: START = (getfileptr bulkstream)") (SETQ PART-LENGTH (CADR PAIR)) (if DISCARDING then (* ; "We already ate some of this, have to skip the rest") (if (> (SETQ DISCARDING (- DISCARDING PART-LENGTH)) 0) then (* ; "We've eaten the entire part, keep discarding") else (* ; "We've eaten all but -DISCARDING bytes") (SETFILEPTR BULKSTREAM (SETQ START (- START DISCARDING))) (SETQ DISCARDING NIL)) else (SETQ END (+ START PART-LENGTH)) (SETQ FINFO (find F in FORWARDINFO suchthat (* ; "See if this is a forwarded part") (FMEMB INDEX (fetch (FORWARD PARTS) of F)))) (SELECTC PART-TYPE ((\NSMAIL.BODY.PART.TYPE HEADING) (* ; "The heading = Sequence of Heading Attribute") (CL:MULTIPLE-VALUE-SETQ (HEADERFIELDS *FORMAT-STREAM* FORWARDINFO) (\NSMAIL.READ.HEADING BULKSTREAM END)) (\NSMAIL.NEW.PRINT.HEADING *MSGSTREAM* HEADERFIELDS *ENVELOPE*) (* ; "Print your basic heading.  May set *BODY-OFFSET*") (if *DISCARDED-PARTS* then (* ; "Add another header field to show what we dropped.") (MAPRINT (CL:REMOVE-DUPLICATES (MAPCAR *DISCARDED-PARTS* (FUNCTION CADR)) :TEST (QUOTE STRING-EQUAL)) *MSGSTREAM* "Discarded-Parts: " NIL ", ") (TERPRI *MSGSTREAM*)) (if *HAVE-ATTACHMENTS* then (* ; "We'll insert image object(s) here later") (PRINTOUT *MSGSTREAM* "
Attachment: " T)) (TERPRI *MSGSTREAM*) (* ; "End header with blank line") (SETQ *HEADER-EOF* (GETFILEPTR *MSGSTREAM*)) (if FORWARDINFO then (* ; "We'll need to buffer the forwarded body parts in order to print them properly") (SETQ FORWARDSTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))))) ((LIST (\NSMAIL.BODY.PART.TYPE MULTINATIONAL.NOTE) (\NSMAIL.BODY.PART.TYPE NSTEXTFILE) (\NSMAIL.BODY.PART.TYPE IA5.NOTE)) (* ; "This is text") (LET ((OUTSTREAM *MSGSTREAM*) (OFFSET *BODY-OFFSET*) FORWARDSTART) (if FINFO then (* ; "We'll buffer this text part") (SETQ FORWARDSTART (GETFILEPTR (SETQ OUTSTREAM FORWARDSTREAM))) (SETQ OFFSET 0) else (* ; "Normal case") (if HAVETEXT then (* ; "yet another text part") (PRIN3 "
- - - - - - -

" *MSGSTREAM*) else (SETQ HAVETEXT T))) (SELECTC PART-TYPE ((\NSMAIL.BODY.PART.TYPE MULTINATIONAL.NOTE) (* ; "Xerox character set--just copy.") (SETFILEPTR BULKSTREAM (+ START OFFSET)) (COPYBYTES BULKSTREAM OUTSTREAM (- PART-LENGTH OFFSET))) ((\NSMAIL.BODY.PART.TYPE IA5.NOTE) (* ; "ia5 takes a little bit of conversion.  Note that the skip case never happens here") (\NSMAIL.COPY.IA5 BULKSTREAM OUTSTREAM PART-LENGTH)) ((\NSMAIL.BODY.PART.TYPE NSTEXTFILE) (* ; "nstextfile--decode serialized file") (\NSMAIL.COPY.NSTEXTFILE BULKSTREAM OUTSTREAM END OFFSET)) NIL) (if FINFO then (* ; "Record where the text went") (push (fetch (FORWARD MAP) of FINFO) (LIST INDEX FORWARDSTART (- (GETFILEPTR FORWARDSTREAM) FORWARDSTART))) else (* ; "We've finished whatever skipping we were going to do.") (SETQ *BODY-OFFSET* 0)))) (LET ((BODY (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) (* ;; "Parts we don't handle become opaque attachments") (if (OR (EQL PART-TYPE (\NSMAIL.BODY.PART.TYPE VPFOLDER)) (EQL PART-TYPE (\NSMAIL.BODY.PART.TYPE VPDOCUMENT)) (EQL PART-TYPE (\NSMAIL.BODY.PART.TYPE OTHERNSFILE))) then (* ; "It's already serialized") (COPYBYTES BULKSTREAM BODY PART-LENGTH) else (* ; "for now, make a serialized file") (COURIER.WRITE BODY \SERIALIZED.FILE.VERSION NIL (QUOTE LONGCARDINAL)) (* ; "version") (\WOUT BODY 1) (* ; "Length of attribute sequence") (\NSMAIL.WRITE.ATTRIBUTE BODY (QUOTE BodyType) (if (EQL PART-TYPE (\NSMAIL.BODY.PART.TYPE INTERPRESS)) then (CONSTANT (\FILETYPE.FROM.TYPE (QUOTE INTERPRESS))) else (+ PART-TYPE 100000000))) (COURIER.WRITE BODY (COURIER.WRITE.STREAM.UNSPECIFIED BODY BULKSTREAM START END) NIL (QUOTE BOOLEAN)) (* ; "StreamOfUnspecified followed by lastByteIsSignificant") (\WOUT BODY 0) (* ; "no children")) (push *ATTACHMENTS* BODY) (if FINFO then (* ; "So we can refer to this later as attachment #n") (push (fetch (FORWARD MAP) of FINFO) (LIST INDEX (LENGTH *ATTACHMENTS*)))))) (if (NOT (EQL END (SETQ START (GETFILEPTR BULKSTREAM)))) then (HELP (CL:FORMAT NIL "Body part ~A wrong length: parsed as ~D, should have been ~D" PART-TYPE (+ PART-LENGTH (- START END)) PART-LENGTH) (CL:FORMAT NIL "Type 'RETURN' to " (if (> START END) then "flush rest of message" else "flush unread portion"))) (if (> START END) then (SETQ DISCARDING (- START END)) else (SETFILEPTR BULKSTREAM (SETQ START END))))) finally (if FORWARDINFO then (* ;; "At this point we have written all the original parts.  Now walk thru the Forwarding info and write those messages") (LET ((*NSMAIL-DISPLAY-TRANSPORT-ID* NIL) (*NSMAIL-DISPLAY-POSTMARK* NIL)) (* ; "Those fields are boring in forwarded mail") (\NSMAIL.EMIT.FORWARDING FORWARDINFO FORWARDSTREAM *MSGSTREAM* NIL))) (* ;; "Return NIL to let Courier result show thru") (RETURN NIL)))
)

(\NSMAIL.COPY.IA5
(LAMBDA (INSTREAM OUTSTREAM NBYTES) (* ; "Edited 22-Dec-89 18:06 by bvm") (* ;; "Convert NBYTES of ia5 text on INSTREAM to Xerox charset on OUTSTREAM") (while (>= (SETQ NBYTES (SUB1 NBYTES)) 0) bind CH do (SELCHARQ (SETQ CH (\BIN INSTREAM)) (CR (* ; "CR followed by some number of lfs indicates line breaks") (bind GOT1 while (AND (>= (SETQ NBYTES (SUB1 NBYTES)) 0) (EQ (SETQ CH (\BIN INSTREAM)) (CHARCODE LF))) do (* ; "One eol for each lf") (\BOUT OUTSTREAM (CHARCODE CR)) (SETQ GOT1 T) finally (if (NOT GOT1) then (* ; "Naked CR?  Well, go ahead and print one anyway--we don't know how else to do it") (\BOUT OUTSTREAM (CHARCODE CR)))) (if (< NBYTES 0) then (* ; "Text ended in eol") (RETURN))) NIL) (\BOUT OUTSTREAM CH)))
)

(\NSMAIL.COPY.NSTEXTFILE
(LAMBDA (INSTREAM OUTSTREAM END OFFSET) (* ; "Edited 22-May-90 10:37 by bvm") (* ;; "Copies the serialized text file from INSTREAM to OUTSTREAM.  If there's a formatting item, sets *FORMAT-STREAM*.  Just in case of trouble, END is the file pointer where we expect the file to end.  If OFFSET is specified, it is an initial number of bytes to skip.") (\NSMAIL.CHECK.SERIALIZED.VERSION INSTREAM) (* ; "Now Sequence of Filing.Attribute") (to (\WIN INSTREAM) bind TYPE do (SETQ TYPE (COURIER.READ INSTREAM NIL (QUOTE LONGCARDINAL))) (if (AND (EQL TYPE (\NSMAIL.ATTRIBUTE.TYPE LispFormatting)) (NOT *FORMAT-STREAM*)) then (* ; "Read formatting") (\NSMAIL.READ.STRING.AS.STREAM INSTREAM (SETQ *FORMAT-STREAM* (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH)))) else (* ; "Skip over the value") (COURIER.SKIP.SEQUENCE INSTREAM NIL (QUOTE UNSPECIFIED)))) (* ;; "Now read the text content.  This is adapted from \nsmail.read.serialized.content") (if (NOT OFFSET) then (SETQ OFFSET 0)) (bind LASTSEGMENT? BYTE BYTECOUNT do (SETQ LASTSEGMENT? (NEQ (\WIN INSTREAM) 0)) (COND ((NEQ (SETQ BYTECOUNT (UNFOLD (\WIN INSTREAM) BYTESPERWORD)) 0) (if (AND (> OFFSET 0) (LET ((SKIPLENGTH (MIN OFFSET BYTECOUNT))) (* ; "How much of this segment to skip") (SETFILEPTR INSTREAM (+ (GETFILEPTR INSTREAM) SKIPLENGTH)) (SETQ OFFSET (- OFFSET SKIPLENGTH)) (EQ (SETQ BYTECOUNT (- BYTECOUNT SKIPLENGTH)) 0))) then (* ; "We skipped the entire segment") (if LASTSEGMENT? then (* ; "Have to consume the lastByteIsSignificant flag") (\WIN INSTREAM)) else (COPYBYTES INSTREAM OUTSTREAM (SUB1 BYTECOUNT)) (SETQ BYTE (\BIN INSTREAM)) (* ; "Final byte of this segment.  Don't copy until we know whether it's significant") (COND ((OR (NULL LASTSEGMENT?) (NEQ (\WIN INSTREAM) 0)) (* ; "Not last segment, or the word after says the final byte was significant") (\BOUT OUTSTREAM BYTE))))) (LASTSEGMENT? (* ; "Null body.  Throw out the lastByteIsSignificant flag") (\WIN INSTREAM))) repeatuntil LASTSEGMENT?) (LET ((NCHILDREN (\WIN INSTREAM))) (if (> NCHILDREN 0) then (HELP "nsTextFile has children!! -- return to skip them" NCHILDREN) (SETFILEPTR INSTREAM END))))
)

(\NSMAIL.READ.HEADING
(LAMBDA (BULKSTREAM HEADING-END) (* ; "Edited 21-Dec-89 17:09 by bvm") (* ;; "Read a Heading body part, which consists of Sequence of Heading Attribute.  Returns 4 values: headerfields (an alist), formatstream (if there was tedit formatting item), forwardInfo (if there was a forwarding structure), malformedP (if we had to advance the file pointer manually to HEADING-END") (LET (TYPE VALUE HEADERFIELDS TYPEINFO DISCARDED FORMATSTREAM FORWARDINFO MALFORMED COURIERTYPE) (to (\WIN BULKSTREAM) do (SETQ TYPE (COURIER.READ BULKSTREAM NIL (QUOTE LONGCARDINAL))) (COND ((NOT (find old TYPEINFO in \NSMAIL.HEADING.ATTRIBUTES suchthat (EQ (CADR TYPEINFO) TYPE))) (* ; "We don't understand this attribute") (if NSMAILDEBUGFLG then (push DISCARDED TYPE)) (COURIER.SKIP.SEQUENCE BULKSTREAM NIL (QUOTE UNSPECIFIED))) ((EQ (SETQ TYPE (CAR TYPEINFO)) (QUOTE LispFormatting)) (* ; "Save the formatting so we can munge it") (SETQ FORMATSTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (\NSMAIL.READ.STRING.AS.STREAM BULKSTREAM FORMATSTREAM)) (T (LET ((VALUE-END (+ (UNFOLD (\WIN BULKSTREAM) BYTESPERWORD) (GETFILEPTR BULKSTREAM))) (COURIERTYPE (CADDR TYPEINFO)) HERE) (* ; "Note careful order of args to +") (if (EQ TYPE (QUOTE ForwardedHeadings)) then (SETQ FORWARDINFO (\NSMAIL.READ.FORWARDING BULKSTREAM VALUE-END)) else (CL:MULTIPLE-VALUE-BIND (VALUE CONDITION) (IGNORE-ERRORS (COURIER.READ BULKSTREAM (QUOTE NEW.MAILTRANSPORT) COURIERTYPE)) (if (OR CONDITION (NOT (EQL (SETQ HERE (GETFILEPTR BULKSTREAM)) VALUE-END))) then (if (NOT CONDITION) then (SETQ CONDITION "wrong length")) (if NSMAILDEBUGFLG then (HELP (CL:FORMAT NIL "Error reading attribute ~A: ~A" TYPE CONDITION))) (push HEADERFIELDS (CONS (MKSTRING TYPE) (CL:FORMAT NIL "XNS encoding error: ~A" CONDITION))) (if (< HERE VALUE-END) then (SETFILEPTR BULKSTREAM VALUE-END) elseif (AND (> HERE VALUE-END) (< HERE HEADING-END)) then (SETFILEPTR BULKSTREAM HEADING-END) (push HEADERFIELDS (QUOTE ("Header-Errors" . "Malformed XNS heading, some fields may be missing."))) (* ; "Exit this heading reader loop") (RETURN (SETQ MALFORMED T))) else (* ; "Save field") (push HEADERFIELDS (CONS TYPE (if (EQ TYPE (QUOTE Immutable)) then (* ; "Strange null-valued type") "True" elseif (LISTP COURIERTYPE) then (if (EQUAL COURIERTYPE (QUOTE (SEQUENCE IP.MESSAGEID))) then (MAPCAR VALUE (FUNCTION \NSMAIL.TRANSLATE.IP.MESSAGEID)) else VALUE) else (SELECTQ COURIERTYPE (TIME (\NSMAIL.GDATE VALUE)) (IP.MESSAGEID (\NSMAIL.TRANSLATE.IP.MESSAGEID VALUE)) VALUE))))))))))) (if DISCARDED then (push HEADERFIELDS (CONS "Discarded-Fields" (CONCATLIST (CDR (for D in (REVERSE DISCARDED) join (LIST ", " D))))))) (CL:VALUES HEADERFIELDS FORMATSTREAM FORWARDINFO MALFORMED)))
)

(\NSMAIL.PARSE.ANNOTATION
(LAMBDA (ANNOTATION OUTSTREAM HEADERFIELDS) (* ; "Edited 21-Dec-89 13:10 by bvm") (* ;; "ANNOTATION is the value of the TextAnnotation heading.  We parse it and print it to OUTSTREAM.  HEADERFIELDS is an alist of other headers the caller will be printing.") (bind (LEN _ (NCHARS ANNOTATION)) (START _ 1) (NEXT _ 1) CR while (SETQ CR (STRPOS "
" ANNOTATION NEXT)) do (CASE (AND (< CR LEN) (CL:CHAR ANNOTATION CR)) ((#\Space #\Tab) (* ; "Whitespace denoting continuation line")) (T (\NSMAIL.EMIT.ANNOTATION (SUBSTRING ANNOTATION START (SUB1 CR)) OUTSTREAM HEADERFIELDS) (SETQ START (ADD1 CR)))) (SETQ NEXT (ADD1 CR)) finally (\NSMAIL.EMIT.ANNOTATION (SUBSTRING ANNOTATION START) OUTSTREAM HEADERFIELDS)))
)

(\NSMAIL.EMIT.ANNOTATION
(LAMBDA (STR OUTSTREAM HEADERFIELDS) (* ; "Edited 10-Jul-90 15:55 by bvm") (DECLARE (SPECVARS *ORIGINAL-DATE*)) (* ;; "Print extra field STR to OUTSTREAM.  We don't know exactly what it looks like, so we need to ensure that it is syntactically ok.  If it is one of HEADERFIELDS, we make sure to rename it to avoid a clash.  If it is the Date field, we print it and set *ORIGINAL-DATE* to the value portion.") (PROG (I LEN FIELD) (if (AND STR (> (SETQ LEN (NCHARS STR)) 0)) then (if (NOT (SETQ FIELD (for old I from 0 to (SUB1 LEN) do (CASE (CL:CHAR STR I) (#\: (* ; "valid field") (RETURN (SUBSTRING STR 1 I))) ((#\Space #\Tab) (* ; "Space before colon?  Malformed") (RETURN NIL)))))) then (* ; "Malformed field") (PRIN3 "Other-Field: " OUTSTREAM) elseif (CL:ASSOC FIELD HEADERFIELDS :TEST (QUOTE STRING-EQUAL)) then (* ; "We already have a field of this name, so rename it") (if (AND (< I (- LEN 2)) (EQL (CL:CHAR STR (ADD1 I)) #\Tab)) then (* ; "field:<tab> looks a little weird when we add text to the front") (CL:SETF (CL:CHAR STR (ADD1 I)) #\Space)) (PRIN3 "Original-" OUTSTREAM) elseif (STRING-EQUAL FIELD "Date") then (SETQ *ORIGINAL-DATE* (LA.TRIM.WHITESPACE (SUBSTRING STR (+ I 2))))) (PRIN3 STR OUTSTREAM) (TERPRI OUTSTREAM))))
)

(LA.TRIM.WHITESPACE
(LAMBDA (STR) (* ; "Edited 14-May-90 16:35 by bvm") (CL:STRING-TRIM (QUOTE (#\Space #\Tab)) STR)))

(\NSMAIL.READ.FORWARDING
(LAMBDA (INSTREAM VALUE-END) (* ; "Edited 21-Dec-89 18:39 by bvm") (* ;; "Read the attribute ForwardedHeadings = Sequence of ForwardedMessageInfo.  We do this instead of a straight COURIER.READ so that we can play with the headings field.  Returns NIL if the attribute is malformed.") (to (\WIN INSTREAM) collect (create FORWARD ENVELOPE _ (COURIER.READ INSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE ENVELOPE)) HEADINGS _ (CL:MULTIPLE-VALUE-BIND (HEADINGS FORMATSTREAM FORWARDINFO MALFORMED) (\NSMAIL.READ.HEADING INSTREAM VALUE-END) (if MALFORMED then (RETURN NIL) else (* ;; "Note that we ignore FORWARDINFO (not allowed anyway, as messages are not quite recursive) and FORMATSTREAM (who would have had it anyway, though it would be cute to be able to use it).") HEADINGS)) PARTS _ (COURIER.READ.SEQUENCE INSTREAM (QUOTE NEW.MAILTRANSPORT) (QUOTE BODY.PART.INDEX)) PARENT _ (if (NEQ (\WIN INSTREAM) 0) then (* ; "Open coding of (choice (null 0 (record)) (nested 1 cardinal))") (\WIN INSTREAM)))))
)

(\NSMAIL.NEW.PRINT.HEADING
(LAMBDA (OUTSTREAM HEADERFIELDS ENVELOPE) (* ; "Edited 26-Sep-90 11:35 by bvm") (* ;; "Compose message header from HEADERFIELDS and ENVELOPE, printing to OUTSTREAM.  ") (PROG (*ORIGINAL-DATE* ORIGIDATE POSTED.DATE ORIGINATOR RETURN-TO VALUE TYPE SENDER FROMFIELD FULLFROMFIELD) (DECLARE (SPECVARS *ORIGINAL-DATE* *BODY-OFFSET*)) (for PAIR in (SETQ HEADERFIELDS (REVERSE HEADERFIELDS)) do (* ; "Before we start printing anything, look for some special fields") (CASE (CAR PAIR) (Sender (SETQ SENDER (CDR PAIR))) (From (SETQ FULLFROMFIELD (CDR PAIR)) (COND ((NULL (CDDR PAIR)) (* ; "Only interesting to eliminate if there's only one") (SETQ FROMFIELD (CADR PAIR))))) ((TextAnnotation newTextAnnotation) (\NSMAIL.PARSE.ANNOTATION (CDR PAIR) OUTSTREAM HEADERFIELDS) (RPLACD PAIR NIL)) (BodyOffset (* ; "Says how much of body duplicates the textannotation") (SETQ *BODY-OFFSET* (CDR PAIR)) (RPLACD PAIR NIL)))) (* ;; "Look at the envelope to see if there is any additional info we should supply that wasn't in the headers") (for PAIR in ENVELOPE do (SETQ VALUE (CADR PAIR)) (CASE (SETQ TYPE (CAR PAIR)) (Originator (if (OR (NULL (OR SENDER FROMFIELD)) (NOT (EQUAL.RNAMES VALUE (OR SENDER FROMFIELD)))) then (SETQ ORIGINATOR VALUE))) (RETURN.TO.NAME (SETQ RETURN-TO VALUE)) (Message-ID (if *NSMAIL-DISPLAY-TRANSPORT-ID* then (CL:FORMAT OUTSTREAM "XNS-Transport-ID: ~{~4,'0x~}~%%" VALUE))) (Postmark (SETQ POSTED.DATE (COURIER.FETCH (NEW.MAILTRANSPORT . POSTMARK) TIME of VALUE)) (if *NSMAIL-DISPLAY-POSTMARK* then (CL:FORMAT OUTSTREAM "Postmark: ~A at ~A~%%" (RNAME.TO.STRING (COURIER.FETCH (NEW.MAILTRANSPORT . POSTMARK) POSTED.AT of VALUE) T) (GDATE POSTED.DATE (DATEFORMAT TIME.ZONE))))))) (if POSTED.DATE then (* ; "Date is found only in the envelope") (if (AND *ORIGINAL-DATE* (SETQ ORIGIDATE (IDATE *ORIGINAL-DATE*)) (< (IABS (- POSTED.DATE ORIGIDATE)) (TIMES 5 60))) then (* ; "Text-annotation portion gave a date that is within 5 minutes, so don't bother mentioning the posting date.") else (if *ORIGINAL-DATE* then (* ; "Already have a Date field printed, so this one we'll call %"Posted-Date%"") (PRINTOUT OUTSTREAM "Posted-")) (PRINTOUT OUTSTREAM "Date: " (\NSMAIL.GDATE POSTED.DATE) T))) (if (NULL FULLFROMFIELD) then (* ; "Derive From field from somewhere else") (if SENDER then (RPLNODE (ASSOC (QUOTE Sender) HEADERFIELDS) (QUOTE From) (LIST SENDER)) (if ORIGINATOR then (push HEADERFIELDS (CONS (QUOTE Sender) ORIGINATOR))) elseif ORIGINATOR then (* ; "Neither From nor Sender in heading, take it out of envelope") (push HEADERFIELDS (LIST (QUOTE From) (SETQ SENDER ORIGINATOR)))) elseif (NULL SENDER) then (* ; "From but no Sender") (if ORIGINATOR then (* ; "ORIGINATOR only set when it's different from From") (push HEADERFIELDS (CONS (QUOTE Sender) (SETQ SENDER ORIGINATOR))) else (SETQ SENDER FROMFIELD)) elseif (AND FROMFIELD (EQUAL.RNAMES SENDER FROMFIELD)) then (* ; "Sender is redundant with From--get rid of it, unless the envelope originator is different") (RPLACD (ASSOC (QUOTE Sender) HEADERFIELDS) ORIGINATOR) elseif ORIGINATOR then (* ; "Three distinct fields") (push HEADERFIELDS (CONS (QUOTE Originator) ORIGINATOR))) (if (AND RETURN-TO (OR (NULL SENDER) (NOT (EQUAL.RNAMES RETURN-TO SENDER))) *NSMAIL-DISPLAY-ERRORS-TO*) then (* ;; "Usually same as originator, so we omit.  (NULL SENDER) is only true when there's no originator in envelope, allegedly illegal") (push HEADERFIELDS (CONS (QUOTE Errors-To) RETURN-TO))) (if (NOT (type? NSNAME SENDER)) then (* ; "Can't resolve domain/orgs against this") (SETQ SENDER NIL)) (for PAIR in (SORT HEADERFIELDS (FUNCTION (LAMBDA (X Y) (* ;; "X sorts before Y if X is in the well-known order and either Y appears after it or doesn't appear at all.  Non-symbols sort after everything") (AND (LITATOM (CAR X)) (OR (NOT (LITATOM (CAR Y))) (AND (SETQ X (FMEMB (CAR X) NSMAIL.HEADER.ORDER)) (OR (FMEMB (CAR Y) X) (NULL (FMEMB (CAR Y) NSMAIL.HEADER.ORDER))))))))) when (SETQ VALUE (CDR PAIR)) do (printout OUTSTREAM (SETQ TYPE (CAR PAIR)) ": ") (CASE TYPE ((From To cc bcc Reply-to) (\NSMAIL.NEW.PRINT.NAMES VALUE OUTSTREAM (SELECTQ TYPE (From (* ; "Always fully qualified.  Also check against sender.") (if (AND SENDER (NOT (for NAME in VALUE always (OR (EQ NAME SENDER) (AND (STRING-EQUAL (fetch NSDOMAIN of NAME) (fetch NSDOMAIN of SENDER)) (STRING-EQUAL (fetch NSORGANIZATION of NAME) (fetch NSORGANIZATION of SENDER))))))) then (* ; "Ugh, From and Sender are different domains.  To reduce confusion, force everything to be fully qualified") (SETQ SENDER NIL)) NIL) (Reply-to (* ; "always full-qualified") NIL) SENDER))) ((Sender Originator Errors-To) (printout OUTSTREAM (RNAME.TO.STRING VALUE T))) (T (if (LISTP VALUE) then (* ; "List of things we'll print as each thing separated by spaces (e.g., References)") (SETQ VALUE (CONCATLIST (CDR (for X in VALUE join (LIST " " X)))))) (while (AND (> (NCHARS VALUE) 0) (EQ (NTHCHARCODE VALUE -1) (CHARCODE CR))) do (* ; "Trailing cr's, e.g., in the Subject line, will cause the header not to parse") (SETQ VALUE (SUBSTRING VALUE 1 -2))) (bind (CR _ 1) while (SETQ CR (STRPOS "
" VALUE CR)) do (* ; "Given internal CR, have to make sure subsequent lines are continuation lines, i.e., start with whitespace.") (SELCHARQ (NTHCHARCODE VALUE (ADD1 CR)) ((SPACE TAB) (* ; "It's ok, let it go") (SETQ CR (ADD1 CR))) (PROGN (* ; "Not followed by whitespace, so print this much (including cr), then a tab.") (PRIN3 (SUBSTRING VALUE 1 CR) OUTSTREAM) (PRINTCCODE (CHARCODE TAB) OUTSTREAM) (SETQ VALUE (SUBSTRING VALUE (ADD1 CR))) (SETQ CR 1)))) (PRIN3 VALUE OUTSTREAM))) (TERPRI OUTSTREAM))))
)

(\NSMAIL.NEW.PRINT.NAMES
(LAMBDA (RNAMES OUTSTREAM DEFAULTNAME) (* ; "Edited  4-Apr-90 17:32 by bvm") (for NAME in RNAMES bind (FIRSTTIME _ T) ORGDIFFERS do (if (type? NSNAME NAME) then (COND (FIRSTTIME (SETQ FIRSTTIME NIL)) (T (PRIN3 ", " OUTSTREAM))) (PRIN3 (fetch NSOBJECT of NAME) OUTSTREAM) (LET ((ORG (fetch NSORGANIZATION of NAME)) (DOM (fetch NSDOMAIN of NAME))) (if (OR (SETQ ORGDIFFERS (NOT (AND DEFAULTNAME (OR (STRING-EQUAL ORG (fetch NSORGANIZATION of DEFAULTNAME)) (EQ (NCHARS ORG) 0))))) (NOT (OR (STRING-EQUAL DOM (fetch NSDOMAIN of DEFAULTNAME)) (EQ (NCHARS DOM) 0)))) then (* ;; "Have to print the domain.  The null string tests are because there exists buggy software that doesn't fill in the domain and org--we want them to default correctly eventually.") (PRIN3 ":" OUTSTREAM) (PRIN3 DOM OUTSTREAM) (if ORGDIFFERS then (* ; "Have to print the org, too") (PRIN3 ":" OUTSTREAM) (PRIN3 ORG OUTSTREAM)))) else (PRIN3 (RNAME.TO.STRING NAME) OUTSTREAM))))
)

(\NSMAIL.EMIT.FORWARDING
(LAMBDA (FORWARDINFO FORWARDSTREAM OUTSTREAM PARENT-INDEX) (* ; "Edited 22-May-90 10:41 by bvm") (* ;; "Recursively emit Forwarded body structure.  In this pass, we print all the body parts subsidiary to the PARENT-INDEXth item, or the top level items if PARENT-INDEX is nil.") (for FINFO in FORWARDINFO as I from 0 bind NTHTIME when (EQ (fetch (FORWARD PARENT) of FINFO) PARENT-INDEX) do (* ;; "This bit of forwarding info describes a child of PARENT-INDEX") (LET ((*BODY-OFFSET* 0)) (DECLARE (SPECVARS *BODY-OFFSET*)) (* ; "set by \nsmail.new.print.heading") (TERPRI OUTSTREAM) (PRIN3 (if NTHTIME then (* ; "%"Next Message%"") (CADDR LAFITEFORWARDSTRINGS) else (SETQ NTHTIME T) (* ; "%"Begin Forwarded Messages%"") (CADR LAFITEFORWARDSTRINGS)) OUTSTREAM) (TERPRI OUTSTREAM) (\NSMAIL.NEW.PRINT.HEADING OUTSTREAM (fetch (FORWARD HEADINGS) of FINFO) (fetch (FORWARD ENVELOPE) of FINFO)) (* ; "Print header of this part") (TERPRI OUTSTREAM) (for INDEX in (fetch (FORWARD PARTS) of FINFO) bind (MAP _ (fetch (FORWARD MAP) of FINFO)) MAPENTRY NTHPART do (if NTHPART then (* ; "Yet another body part") (PRIN3 "
- - - - - - -

" OUTSTREAM) else (SETQ NTHPART T)) (if (NOT (SETQ MAPENTRY (CDR (ASSOC INDEX MAP)))) then (PRIN3 "[Missing part]
" OUTSTREAM) elseif (CDR MAPENTRY) then (* ; "(start length)") (SETFILEPTR FORWARDSTREAM (+ (CAR MAPENTRY) *BODY-OFFSET*)) (COPYBYTES FORWARDSTREAM OUTSTREAM (CADR MAPENTRY)) (SETQ *BODY-OFFSET* 0) else (* ; "(attachment#)") (if (CL:FORMAT OUTSTREAM "[See Attachment #~D]~%%" (CAR MAPENTRY)))))) (* ; "If there are children, do them") (\NSMAIL.EMIT.FORWARDING FORWARDINFO FORWARDSTREAM OUTSTREAM I) finally (if NTHTIME then (* ; "Yes, we printed some parts, so time for %"End Forwarded Messages%"") (TERPRI OUTSTREAM) (PRIN3 (CADDDR LAFITEFORWARDSTRINGS) OUTSTREAM))))
)

(\NSMAIL.GDATE
(LAMBDA (TIME) (* ; "Edited 11-Jul-90 18:03 by bvm") (GDATE TIME (DATEFORMAT SPACES TIME.ZONE))))

(\NSMAIL.TRANSLATE.IP.MESSAGEID
(LAMBDA (ID) (* ; "Edited 11-May-90 10:45 by bvm") (LET ((RNAME (COURIER.FETCH (NEW.MAILTRANSPORT . IP.MESSAGEID) ORIGINATOR of ID)) (USTRING (COURIER.FETCH (NEW.MAILTRANSPORT . IP.MESSAGEID) UNIQUESTRING of ID))) (if (NOT (NULL.NSNAME RNAME)) then (* ; "Really has name") (CONCAT #\< USTRING #\* (RNAME.TO.STRING RNAME T) #\>) elseif (AND (EQ (CL:CHAR USTRING 0) #\<) (EQ (CL:CHAR USTRING (SUB1 (NCHARS USTRING))) #\>)) then (* ; "It's already in msg-id format") USTRING else (\NSMAIL.MAYBE.QUOTE USTRING))))
)

(\NSMAIL.MAYBE.QUOTE
(LAMBDA (STR) (* ; "Edited 11-May-90 10:44 by bvm") (* ;; "return STR with string quotes around it if it contains any characters that RFC822 says are special") (if (for I from 1 to (NCHARS STR) bind CH thereis (OR (< (SETQ CH (NTHCHARCODE STR I)) (CHARCODE SPACE)) (>= CH (CHARCODE DEL)) (FMEMB CH (CHARCODE ("(" ")" "<" ">" "@" "," ";" ":" \ %" "." "[" "]"))))) then (CONCAT #\" (if (STRPOSL (CHARCODE (\ %")) STR) then (* ; "Have to quote these") (CONCATLIST (for I from 0 to (SUB1 (NCHARS STR)) bind CH join (CASE (SETQ CH (CL:CHAR STR I)) ((#\\ #\") (LIST #\\ CH)) (T (LIST CH))))) else STR) #\") else STR))
)

(NULL.NSNAME
(LAMBDA (NAME) (* ; "Edited 21-Aug-90 11:32 by bvm") (AND (type? NSNAME NAME) (EQL (NCHARS (fetch NSDOMAIN of NAME)) 0) (EQL (NCHARS (fetch NSORGANIZATION of NAME)) 0) (PROGN (* ; "Kludge in new gateway due to bug in backward compatibility--object = single char is also %"null%"") (< (NCHARS (fetch NSOBJECT of NAME)) 2))))
)

(\NSMAIL.HANDLE.DELIVERY.REPORT
(LAMBDA (OUTSTREAM REPORT-RECORD ENVELOPE) (* ; "Edited 29-Jun-90 18:06 by bvm") (LET* ((POSTED.DATE (COURIER.FETCH (NEW.MAILTRANSPORT . POSTMARK) TIME of (CADR (ASSOC (QUOTE Postmark) ENVELOPE)))) (OLD.ENVELOPE (COURIER.FETCH (NEW.MAILTRANSPORT . REPORT) ORIGINAL.ENVELOPE of REPORT-RECORD)) (REPORT (COURIER.FETCH (NEW.MAILTRANSPORT . REPORT) REPORT.TYPE of REPORT-RECORD)) (REPORTVALUE (CADR REPORT)) (FATE (COURIER.FETCH (NEW.MAILTRANSPORT . REPORT) FATE of REPORT-RECORD)) (SENDER (CADR (ASSOC (QUOTE Originator) ENVELOPE))) (RETURN-TO (CADR (ASSOC (QUOTE RETURN.TO.NAME) ENVELOPE))) BADNAMES GOODNAMES) (if POSTED.DATE then (PRINTOUT OUTSTREAM "Date: " (\NSMAIL.GDATE POSTED.DATE) T)) (if SENDER then (PRINTOUT OUTSTREAM "From: " (RNAME.TO.STRING SENDER T) T)) (if (AND RETURN-TO (NOT (EQUAL.RNAMES SENDER RETURN-TO))) then (PRINTOUT OUTSTREAM "Errors-to: " (RNAME.TO.STRING RETURN-TO T) T)) (PRINTOUT OUTSTREAM "Subject: ") (if (EQ (CAR FATE) (QUOTE NOT.DELIVERED)) then (* ; "Bizarre") (PRINTOUT OUTSTREAM "Return of non-delivery notice" T T "This non-delivery report could not be delivered because " (CAR (CADR FATE)) T T "Original-Subject: ")) (CASE (CAR REPORT) (DLMEMBER (* ; "Bad member notification") (SETQ BADNAMES (COURIER.FETCH (NEW.MAILTRANSPORT . DLREPORT) INVALID.RECIPIENTS of REPORTVALUE)) (PRINTOUT OUTSTREAM "Bad group membership notification" T T) (CL:FORMAT OUTSTREAM "A message from ~A could not be delivered to the following member~P of ~A:" (RNAME.TO.STRING (CADR (ASSOC (QUOTE Originator) OLD.ENVELOPE)) T) (LENGTH BADNAMES) (RNAME.TO.STRING (COURIER.FETCH (NEW.MAILTRANSPORT . DLREPORT) DLNAME of REPORTVALUE) T))) (OTHER (SETQ BADNAMES (COURIER.FETCH (NEW.MAILTRANSPORT . OTHER.REPORT) FAILED of REPORTVALUE)) (SETQ GOODNAMES (COURIER.FETCH (NEW.MAILTRANSPORT . OTHER.REPORT) SUCCEEDED of REPORTVALUE)) (if BADNAMES then (PRINTOUT OUTSTREAM "Undeliverable mail" T T) (CL:FORMAT OUTSTREAM "This message could not be delivered to the following recipient~P:" (LENGTH BADNAMES)) else (* ; "Strictly a delivery report") (PRINTOUT OUTSTREAM "Delivery report"))) (T (* ; "Shouldn't happen") (PRINTOUT OUTSTREAM "Erroneous (non-)delivery report" T T REPORT))) (PRINTOUT OUTSTREAM T T) (for PAIR in BADNAMES do (PRINTCCODE (CHARCODE TAB) OUTSTREAM) (PRINTOUT OUTSTREAM (\NSMAIL.RECIPIENT.NAME (COURIER.FETCH (NEW.MAILTRANSPORT . NON.DELIVERED.RECIPIENT) RECIPIENT of PAIR)) " -- " (COURIER.FETCH (NEW.MAILTRANSPORT . NON.DELIVERED.RECIPIENT) REASON of PAIR) T)) (if GOODNAMES then (* ; "A delivery report") (if BADNAMES then (TERPRI OUTSTREAM)) (CL:FORMAT OUTSTREAM "This message was delivered to the following recipient~P:~2%%" (LENGTH GOODNAMES)) (for PAIR in GOODNAMES do (PRINTCCODE (CHARCODE TAB) OUTSTREAM) (PRINTOUT OUTSTREAM (\NSMAIL.RECIPIENT.NAME (COURIER.FETCH (NEW.MAILTRANSPORT . DELIVERED.RECIPIENT) RECIPIENT of PAIR)) " at " (\NSMAIL.GDATE (COURIER.FETCH (NEW.MAILTRANSPORT . DELIVERED.RECIPIENT) WHEN of PAIR) (DATEFORMAT TIME.ZONE)) T))) OLD.ENVELOPE))
)

(\NSMAIL.RECIPIENT.NAME
(LAMBDA (RECIPIENT) (* ; "Edited  4-Apr-90 17:26 by bvm") (* ;; "Printable rep for a MailTransport.Recipient") (RNAME.TO.STRING (COURIER.FETCH (NEW.MAILTRANSPORT . RECIPIENT) NAME of RECIPIENT) T))
)

(NEW.INBASKET.CALL
(CL:LAMBDA (MAILBOX PROCEDURE &REST ARGS) (* ; "Edited 13-Dec-89 17:17 by bvm") (PROG ((STREAM (fetch NSMAILSTREAM of MAILBOX)) RESULT) LP (if (AND (EQ (CAR (LISTP (SETQ RESULT (CL:APPLY (FUNCTION COURIER.CALL) STREAM (QUOTE NEW.INBASKET) PROCEDURE ARGS)))) (QUOTE ERROR)) (CASE (CAR (LAST ARGS)) (NOERROR NIL) (RETURNERRORS (* ; "We'll only handle stream lost--caller gets the rest") (EQ (CADR RESULT) (QUOTE STREAM.LOST))) (T (* ; "Probably an error was already signaled") T))) then (SETQ STREAM (\NSMAIL.SIGNAL.ERROR RESULT MAILBOX (QUOTE NEW.INBASKET) PROCEDURE)) (GO LP) else (RETURN RESULT))))
)

(NEWNS.CLOSEMAILBOX
(LAMBDA (MAILBOX FLUSH?) (* ; "Edited 18-Dec-89 17:35 by bvm") (COND (FLUSH? (* ; "Delete everything we retrieved") (LET ((INDICES (REVERSE (fetch NSMAILENVELOPES of MAILBOX))) (SESSION (fetch NSMAILSESSION of MAILBOX))) (while INDICES do (* ; "Delete a message or more.  To keep the calls down, try to delete consecutive ranges when possible.") (LET* ((START (CAR INDICES)) (END START)) (while (AND (SETQ INDICES (CDR INDICES)) (EQL (CAR INDICES) (ADD1 END))) do (SETQ END (ADD1 END))) (NEW.INBASKET.CALL MAILBOX (QUOTE DELETE) (COURIER.CREATE (NEW.INBASKET . RANGE) LOW _ START HIGH _ END) SESSION)))))) (\NSMAIL.NEW.LOGOFF (fetch NSMAILSTATE of MAILBOX) (fetch NSMAILSTREAM of MAILBOX)))
)

(\NSMAIL.NEW.LOGOFF
(LAMBDA (STATE STREAM) (* ; "Edited 19-Dec-89 11:08 by bvm") (* ;; "Executes the Inbasket.Logoff procedure and clears appropriate state.  Returns true if LOGOFF call succeeded.") (LET ((RESULT (COURIER.CALL STREAM (QUOTE NEW.INBASKET) (QUOTE LOGOFF) (fetch STATESESSION of STATE) (QUOTE RETURNERRORS)))) (PROG1 (NEQ (CAR (LISTP RESULT)) (QUOTE ERROR)) (replace STATESESSION of STATE with NIL) (CLOSEF STREAM))))
)
)

(RPAQQ \NSMAIL.GOOD.BODY.PARTS (0 5 6 2))

(RPAQQ \NSMAIL.DISCARDABLE.BODY.PARTS ((201 "Tioga formatting") (202 "Tioga header")))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \NSMAIL.GOOD.BODY.PARTS \NSMAIL.DISCARDABLE.BODY.PARTS)
)

(ADDTOVAR LAFITEMODELST (NS 1 \NSMAIL.SEND.PARSE \NSMAIL.NEW.SEND \NSMAIL.MAKEANSWERFORM \NSMAIL.NEW.AUTHENTICATE \NSMAIL.MESSAGE.P \NSMAIL.MESSAGE.FROM.SELF.P \NSMAIL.LOGIN))

(LAFITEMODE (LAFITEMODE))

(COND ((AND *USE-NEW-NSMAIL* \LAFITE.ACTIVE) (* ; "recache") (LAFITECLEARCACHE)))



(* ; "Old ns mail")

(DEFINEQ

(\NS.READ.ENVELOPE.ITEM
(LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 22-Nov-89 12:11 by bvm") (* ;; "Reads a mailing envelope attribute value pair from STREAM, returning a list of two elements, (TYPE VALUE);  if the attribute is not a known attribute, TYPE is an integer and VALUE is a sequence of unspecified") (LET* ((TYPE (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) (VALUETYPE (\COMPUTED.FORM (BQUOTE (CASE TYPE (\,@ (for TRIPLE in \NSMAIL.ENVELOPE.ITEM.TYPES collect (BQUOTE ((\, (CADR TRIPLE)) (SETQ TYPE (QUOTE (\, (CAR TRIPLE)))) (QUOTE (\, (CADDR TRIPLE)))))))))))) (LIST TYPE (if VALUETYPE then (\WIN STREAM) (* ; "Skip sequence count") (COURIER.READ STREAM PROGRAM VALUETYPE) else (COURIER.READ.SEQUENCE STREAM NIL (QUOTE UNSPECIFIED))))))
)

(\NS.WRITE.ENVELOPE.ITEM
(LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 22-Nov-89 12:31 by bvm") (* ;;; "Writes a filing attribute value pair to STREAM.  ITEM is a list of two elements (TYPE VALUE)") (LET ((TYPE (CAR ITEM)) (VALUE (CADR ITEM)) VALUETYPE) (COURIER.WRITE STREAM (OR (FIXP TYPE) (\COMPUTED.FORM (BQUOTE (CASE TYPE (\,@ (for TRIPLE in \NSMAIL.ENVELOPE.ITEM.TYPES collect (BQUOTE ((\, (CAR TRIPLE)) (SETQ VALUETYPE (QUOTE (\, (CADDR TRIPLE)))) (QUOTE (\, (CADR TRIPLE))))))) (T (ERROR "Unknown Envelope Item Type" TYPE)))))) NIL (QUOTE LONGCARDINAL)) (COND (VALUETYPE (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE PROGRAM VALUETYPE)) (T (COURIER.WRITE.SEQUENCE STREAM VALUE PROGRAM (QUOTE UNSPECIFIED))))))
)
)

(RPAQQ \NSMAIL.ENVELOPE.ITEM.TYPES ((Postmark 0 POSTMARK) (Message-ID 1 MESSAGEID) (ContentsType 2 LONGCARDINAL) (CONTENTS.SIZE 3 LONGCARDINAL) (Originator 4 RNAME) (TransportProblem 6 PROBLEM) (RETURN.TO.NAME 7 RNAME) (Previous-Recipients 8 RNAME.LIST) (BodyType 17 LONGCARDINAL) (Status 1000 (INBASKET . STATUS))))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)

(DECLARE%: EVAL@COMPILE

(RECORD FORWARD (ENVELOPE HEADINGS PARTS PARENT . MAP))
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS \COMPUTED.FORM MACRO (X (CONS (QUOTE PROGN) (MAPCAR X (FUNCTION EVAL)))))

(PUTPROPS \NSMAIL.BODY.PART.TYPE MACRO (ARGS (COND ((CADR (ASSOC (CAR ARGS) \NSMAIL.BODY.PART.TYPES))) (T (ERROR "Unknown body part type" (CAR ARGS)) (QUOTE IGNOREMACRO)))))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \NSMAIL.BODY.PART.TYPES \NSMAIL.HEADING.ATTRIBUTES)
)


(FILESLOAD (SOURCE) LAFITEDECLS)


(FILESLOAD (LOADCOMP) NSMAIL)


(RPAQQ \NSMAIL.CONTENTS.TYPES ((\CT.NULL 0) (\CT.STANDARD.MESSAGE 4) (\CT.REPORT 6)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \CT.NULL 0)

(RPAQQ \CT.STANDARD.MESSAGE 4)

(RPAQQ \CT.REPORT 6)


(CONSTANTS (\CT.NULL 0) (\CT.STANDARD.MESSAGE 4) (\CT.REPORT 6))
)
DOCOPY 

(RPAQQ \NSMAIL.BODY.PART.TYPES ((HEADING 0) (VPFOLDER 1) (NSTEXTFILE 2) (VPDOCUMENT 3) (OTHERNSFILE 4) (MULTINATIONAL.NOTE 5) (IA5.NOTE 6) (PILOTFILE 7) (G3FAX 8) (TELETEX 9) (TELEX 10) (ISO6937.NOTE 11) (INTERPRESS 12)))
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA)

(ADDTOVAR NLAML)

(ADDTOVAR LAMA NEW.INBASKET.CALL)
)
(PUTPROPS NEWNSMAIL COPYRIGHT ("Xerox Corporation" 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (12380 13895 (\NS.NEW.READ.ENVELOPE.ITEM 12390 . 13155) (\NS.NEW.WRITE.ENVELOPE.ITEM 
13157 . 13893)) (14631 16309 (\NS.READ.HEADING.ATTRIBUTE 14641 . 15619) (\NS.WRITE.HEADING.ATTRIBUTE 
15621 . 16307)) (17196 18599 (\NSMAIL.READ.RNAME 17206 . 17764) (\NSMAIL.WRITE.RNAME 17766 . 18257) (
\NSMAIL.RNAME.LENGTH 18259 . 18597)) (18695 20769 (RNAME.TO.STRING 18705 . 18884) (X400.NAME.TO.STRING
 18886 . 20573) (EQUAL.RNAMES 20575 . 20767)) (20794 40694 (\NSMAIL.NEW.SEND.PARSE 20804 . 23178) (
\NSMAIL.CHECK.ENUMERATION 23180 . 24099) (\NSMAIL.NEW.SEND 24101 . 33237) (
\NSMAIL.NEW.INVALID.RECIPIENTS 33239 . 33820) (\NSMAIL.BUILD.HEADING 33822 . 35121) (
\NSMAIL.POST.BODY.PART 35123 . 36954) (\NSMAIL.NEW.PREPARE.ATTACHMENT 36956 . 38277) (
\NSMAIL.CHECK.ABORT 38279 . 38637) (\NSMAIL.NEW.FINDSERVER 38639 . 39694) (\NSMAIL.NEW.CHECKSERVER 
39696 . 40692)) (42644 83283 (\NSMAIL.NEW.AUTHENTICATE 42654 . 44139) (NEWNS.POLLNEWMAIL 44141 . 44456
) (NEWNS.OPENMAILBOX 44458 . 45142) (\NSMAIL.NEW.CHECK 45144 . 49574) (NEWNS.NEXTMESSAGE 49576 . 50070
) (NEWNS.RETRIEVEMESSAGE 50072 . 53936) (\NSMAIL.READ.BODY.PARTS 53938 . 59349) (\NSMAIL.COPY.IA5 
59351 . 60100) (\NSMAIL.COPY.NSTEXTFILE 60102 . 62251) (\NSMAIL.READ.HEADING 62253 . 64988) (
\NSMAIL.PARSE.ANNOTATION 64990 . 65724) (\NSMAIL.EMIT.ANNOTATION 65726 . 66994) (LA.TRIM.WHITESPACE 
66996 . 67118) (\NSMAIL.READ.FORWARDING 67120 . 68145) (\NSMAIL.NEW.PRINT.HEADING 68147 . 73771) (
\NSMAIL.NEW.PRINT.NAMES 73773 . 74749) (\NSMAIL.EMIT.FORWARDING 74751 . 76585) (\NSMAIL.GDATE 76587 . 
76703) (\NSMAIL.TRANSLATE.IP.MESSAGEID 76705 . 77252) (\NSMAIL.MAYBE.QUOTE 77254 . 77892) (NULL.NSNAME
 77894 . 78236) (\NSMAIL.HANDLE.DELIVERY.REPORT 78238 . 81269) (\NSMAIL.RECIPIENT.NAME 81271 . 81498) 
(NEW.INBASKET.CALL 81500 . 82124) (NEWNS.CLOSEMAILBOX 82126 . 82842) (\NSMAIL.NEW.LOGOFF 82844 . 83281
)) (83836 85335 (\NS.READ.ENVELOPE.ITEM 83846 . 84603) (\NS.WRITE.ENVELOPE.ITEM 84605 . 85333)))))
STOP
\ No newline at end of file
diff --git a/internal/library/NSMAIL b/internal/library/NSMAIL
new file mode 100644
index 00000000..c41cbeec
--- /dev/null
+++ b/internal/library/NSMAIL
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Jun-90 18:42:52" {DSK}<usr>local>lde>lispcore>internal>library>NSMAIL.;3 132387 

      changes to%:  (VARS NSMAILCOMS)
                    (FNS NS.POLLNEWMAIL NS.OPENMAILBOX \NSMAIL.CHECK \NSMAIL.FIX.MAILBOX.LOCATIONS 
                         NS.NEXTMESSAGE \NSMAIL.READ.ENVELOPES INBASKET.CALL NS.RETRIEVEMESSAGE 
                         \NSMAIL.RETRIEVE \NSMAIL.SIGNAL.ERROR NS.CLOSEMAILBOX \NSMAIL.LOGOFF 
                         \NSMAIL.CHANGE.STATUS \MAILOBJ.DISPLAY \MAILOBJ.IMAGEBOX \MAILOBJ.PUT 
                         \MAILOBJ.BUTTONEVENTFN \MAILOBJ.HARDCOPY \MAILOBJ.FB \MAILOBJ.PUT.FILE 
                         \MAILOBJ.VIEW \MAILOBJ.EXPAND \NSMAIL.SEND)

      previous date%: "14-Feb-90 17:23:04" {DSK}<usr>local>lde>lispcore>internal>library>NSMAIL.;2)


(* ; "
Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT NSMAILCOMS)

(RPAQQ NSMAILCOMS
       [(COMS                                                (* ; "Basic mail protocol")
              (COURIERPROGRAMS MAILTRANSPORT INBASKET)
              (FNS \NSMAIL.AUTHENTICATE \NSMAIL.MAKE.MAILSERVERS \NSMAIL.LOGIN NS.FINDMAILBOXES)
              (ALISTS (LAFITEMODELST NS STAR)))
        (COMS                                                (* ; "Retrieving mail")
              (FNS NS.POLLNEWMAIL NS.OPENMAILBOX \NSMAIL.CHECK \NSMAIL.FIX.MAILBOX.LOCATIONS 
                   NS.NEXTMESSAGE \NSMAIL.READ.ENVELOPES INBASKET.CALL NS.RETRIEVEMESSAGE 
                   \NSMAIL.RETRIEVE \NSMAIL.EOF.ON.RETRIEVE \NSMAIL.READ.SERIALIZED.TREE 
                   \NSMAIL.CHECK.SERIALIZED.VERSION \NSMAIL.READ.SERIALIZED.CONTENT 
                   \NSMAIL.DISCARD.SERIALIZED.CONTENT \NSMAIL.READ.STRING.AS.STREAM 
                   \NSMAIL.PRINT.HEADERFIELDS \NSMAIL.PRINT.NAMES)
                                                             (* ; "Error handling")
              (FNS \NSMAIL.COURIER.OPEN \NSMAIL.ERRORHANDLER \NSMAIL.SIGNAL.ERROR)
                                                             (* ; "Close/flush protocol")
              (FNS NS.CLOSEMAILBOX \NSMAIL.LOGOFF \NSMAIL.CHANGE.STATUS)
              [INITVARS (NSMAILDEBUGFLG)
                     (NSMAIL.LEAVE.ATTACHMENTS)
                     (NSMAIL.HEADER.ORDER '(Date Sender From Subject In-Reply-to To cc Message-ID 
                                                 Reply-to]
              (ADDVARS (\NSMAIL.GOOD.BODYTYPES 2 4)))
        [COMS                                                (* ; 
                                           "Handling attachments as a special kind of image object")
              (FNS \MAILOBJ.CREATE \MAILOBJ.TYPE.NAME \MAILOBJ.NS.TO.LISP.NAME \MAILOBJ.DISPLAY 
                   \MAILOBJ.GET \MAILOBJ.IMAGEBOX \MAILOBJ.PUT \MAILOBJ.INIT)
              (FNS \MAILOBJ.BUTTONEVENTFN \MAILOBJ.DO.COMMAND \MAILOBJ.HARDCOPY \MAILOBJ.FB 
                   \MAILOBJ.PUT.FILE \MAILOBJ.VIEW \MAILOBJ.MUNGE.NAME \MAILOBJ.COPY.BODY 
                   \MAILOBJ.EXPAND \MAILOBJ.COPY.CHILD \MAILOBJ.COPY.SEQUENCE \MAILOBJ.EXTRACT.TEXT 
                   \MAILOBJ.PARSE.ATTRIBUTES)
              (ADDVARS (FILING.TYPES (VIEWPOINT 4353)
                              (RES 4428)
                              (XEROX860 5120)
                              (REFERENCE 4427)
                              (MAILFOLDER 4417)))
              (VARS MAILOBJ.REFERENCE.FIELD)
              (INITVARS (MAILOBJ.WINDOWOFFSET 16)
                     (MAILOBJ.SKIPCHAR (CHARCODE ".")))
              (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MAILOBJ)
                     (CONSTANTS \MAILOBJ.REFERENCE.LAST.FILED))
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\MAILOBJ.INIT)
                                                 (AND (EQ MAKESYSNAME :LYRIC)
                                                      (FILESLOAD (SYSLOAD)
                                                             NSRANDOM]
        (COMS                                                (* ; "sending mail")
              (FNS \NSMAIL.SEND.PARSE \NSMAIL.PARSE.REFERENCE \NSMAIL.EXPAND.DL \NSMAIL.PARSE 
                   \NSMAIL.PARSE1 NS.REMOVEDUPLICATES \NSMAIL.SEND \NSMAIL.PREPARE.ATTACHMENT 
                   \NSMAIL.GUESS.FILE.TYPE \NSMAIL.SEND.MESSAGE.CONTENT 
                   COURIER.WRITE.STREAM.UNSPECIFIED \NSMAIL.SEND.STREAM.AS.STRING 
                   \NSMAIL.WRITE.ATTRIBUTE \NSMAIL.FINDSERVER \NSMAIL.CHECKSERVER)
              (FILES LAFITEMAIL)
                                                             (* ; "for LAFITE.MAKE.PARSE.TABLE")
              (VARS NSMAIL.PARSEFIELDS (\LAPARSE.NSMAIL (LAFITE.MAKE.PARSE.TABLE NSMAIL.PARSEFIELDS))
                    )
              (GLOBALVARS \LAPARSE.NSMAIL)
              (INITVARS (\NSMAIL.SERVER.CACHE)
                     (NSMAIL.NET.HINT)
                     (*NSMAIL-MAX-NOTE-LENGTH* 8000)
                     (*NSMAIL-SEND-MAIL-NOTES*)
                     (*NSMAIL-CACHE-TIMEOUT* 14400000)
                     (LAFITEDL.EXT "DL"))
              [P (CL:PROCLAIM '(GLOBAL NSMAIL.NET.HINT *NSMAIL-MAX-NOTE-LENGTH* 
                                      *NSMAIL-SEND-MAIL-NOTES* *NSMAIL-CACHE-TIMEOUT*]
              (ADDVARS (\SYSTEMCACHEVARS \NSMAIL.SERVER.CACHE))
              (FNS \NSMAIL.MESSAGE.P \NSMAIL.MESSAGE.FROM.SELF.P \NSMAIL.MAKEANSWERFORM))
        (COMS                                                (* ; 
                                                           "Utility for handling mail attributes")
              (PROP COURIERDEF ENVELOPE.ITEM)
              (FNS \NS.READ.ENVELOPE.ITEM \NS.WRITE.ENVELOPE.ITEM)
              (VARS \NSMAIL.ENVELOPE.ITEM.TYPES)
              (DECLARE%: EVAL@COMPILE DOCOPY (VARS \NSMAIL.ATTRIBUTES)))
        (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS NSMAILBOX NSMAILSTATE NSMAILPARSE)
               (CONSTANTS \NSMAIL.SOCKET \SERIALIZED.FILE.VERSION \SERIALIZED.FILE.VERSIONS 
                      \NSMAIL.CTSTANDARD.MESSAGE \NSMAIL.TEXT.BODYTYPE \NSMAIL.EMPTY.BODYTYPE 
                      \NSMAIL.REFERENCE.BODYTYPE MAX.BULK.SEGMENT.LENGTH \NULL.CACHE.VERIFIER)
               (MACROS \NSMAIL.ATTRIBUTE.TYPE \NSMAIL.WRITE.ATTRIBUTE \NSMAIL.WRITE.ATTRIBUTE.MACRO)
               (PROP INFO \NSMAIL.ATTRIBUTE.TYPE)
               (GLOBALVARS NSMAIL.NET.HINT \NSMAIL.ENVELOPE.ITEM.TYPES \NSMAIL.ATTRIBUTES 
                      \NSMAIL.SERVER.CACHE NSMAILDEBUGFLG NSWIZARDFLG NSMAIL.LEAVE.ATTACHMENTS 
                      \NSMAIL.GOOD.BODYTYPES MAILOBJ.WINDOWOFFSET MAILOBJ.SKIPCHAR \MAILOBJ.IMAGEFNS
                      MAILOBJ.REFERENCE.FIELD \NSFILING.ATTRIBUTES DEFAULTICONFONT NSPRINT.WATCHERFLG
                      NSMAIL.HEADER.ORDER FILING.TYPES)
               [P (CL:PROCLAIM '(CL:SPECIAL *RETRIEVAL-ERROR*]
               (FILES (SOURCE)
                      LAFITEDECLS)
               (FILES (LOADCOMP)
                      CLEARINGHOUSE)
               (LOCALVARS . T))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA INBASKET.CALL])



(* ; "Basic mail protocol")


(COURIERPROGRAM MAILTRANSPORT (17 4)
    TYPES
      [(CREDENTIALS (AUTHENTICATION . CREDENTIALS))
       (VERIFIER (AUTHENTICATION . VERIFIER))
       (ENVELOPE.ITEM.TYPE LONGCARDINAL)
       (ENVELOPE (SEQUENCE ENVELOPE.ITEM))
       (INVALID.NAME (RECORD (REASON INVALID.NAME.REASON)
                            (NAME RNAME)))
       (INVALID.NAME.LIST (SEQUENCE INVALID.NAME))
       (INVALID.NAME.REASON (ENUMERATION (NoSuchRecipient 0)
                                   (CantValidateNow 1)
                                   (IllegalName 2)
                                   (Refused 3)
                                   (NoAccessToDl 4)
                                   (Timeout 5)
                                   (NoDlsAllowed 6)
                                   (MessageTooLong 7)))
       (NAME (CLEARINGHOUSE . NAME))
       (NAME.LIST (SEQUENCE NAME))
       (RNAME NAME)
       (RNAME.LIST (SEQUENCE RNAME))
       (WILLINGNESS CARDINAL)
       (CONTENTS.TYPE LONGCARDINAL)
       (MESSAGEID (ARRAY 5 UNSPECIFIED))
       (POSTMARK (RECORD (POSTED.AT NAME)
                        (TIME TIME)))
       (PROBLEM (RECORD (UNDELIVERABLES INVALID.NAME.LIST)
                       (RETURNED.ENVELOPE ENVELOPE)))
       (CONNECTION.PROBLEM (FILING . CONNECTION.PROBLEM))
       (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0)
                               (ServiceFull 1)
                               (ServiceUnavailable 2)
                               (MediumFull 3)))
       (TRANSFER.PROBLEM (ENUMERATION (Aborted 0)
                                (NoRendezvous 1)
                                (WrongDirection 4]
    PROCEDURES
      ((SERVER.POLL 0 (CREDENTIALS VERIFIER)
              RETURNS
              (WILLINGNESS (CLEARINGHOUSE . NETWORK.ADDRESS.LIST)
                     VERIFIER NAME))
       (POST 1 (CREDENTIALS VERIFIER RNAME.LIST BOOLEAN BOOLEAN CONTENTS.TYPE ENVELOPE 
                      BULK.DATA.SOURCE)
             RETURNS
             (INVALID.NAME.LIST MESSAGEID)
             REPORTS
             (AUTHENTICATION.ERROR CONNECTION.ERROR INVALID.RECIPIENTS SERVICE.ERROR TRANSFER.ERROR 
                    UNDEFINED.ERROR)))
    ERRORS
      ((AUTHENTICATION.ERROR 1 ((AUTHENTICATION . PROBLEM)))
       (CONNECTION.ERROR 2 (CONNECTION.PROBLEM))
       (INVALID.RECIPIENTS 3 (INVALID.NAME.LIST))
       (SERVICE.ERROR 4 (SERVICE.PROBLEM))
       (TRANSFER.ERROR 5 (TRANSFER.PROBLEM))
       (UNDEFINED.ERROR 6 (CARDINAL))))

(COURIERPROGRAM INBASKET (18 1)
    INHERITS
      (MAILTRANSPORT)
    TYPES
      [(CREDENTIALS (AUTHENTICATION . CREDENTIALS))
       (VERIFIER (AUTHENTICATION . VERIFIER))
       (SESSION (RECORD (HANDLE (ARRAY 2 UNSPECIFIED))
                       (VERIFIER VERIFIER)))
       (ENVELOPE.ITEM.TYPE LONGCARDINAL)
       (ENVELOPE (SEQUENCE ENVELOPE.ITEM))
       (INVALID.NAME (RECORD (REASON INVALID.NAME.REASON)
                            (NAME RNAME)))
       (INVALID.NAME.LIST (SEQUENCE INVALID.NAME))
       (INVALID.NAME.REASON (ENUMERATION (NoSuchRecipient 0)
                                   (CantValidateNow 1)
                                   (IllegalName 2)
                                   (Refused 3)
                                   (NoAccessToDl 4)
                                   (Timeout 5)
                                   (NoDlsAllowed 6)
                                   (MessageTooLong 7)))
       (NAME (CLEARINGHOUSE . NAME))
       (NAME.LIST (SEQUENCE NAME))
       (RNAME NAME)
       (RNAME.LIST (SEQUENCE RNAME))
       (CONTENTS.TYPE LONGCARDINAL)
       (INDEX CARDINAL)
       (INBASKET.STATE (RECORD (LASTINDEX INDEX)
                              (NEWCOUNT CARDINAL)
                              (ISPRIMARY BOOLEAN)
                              (ISPRIMARYUP BOOLEAN)))
       (RANGE (RECORD (FIRST INDEX)
                     (LAST INDEX)))
       (MAIL.ATTRIBUTE.TYPE LONGCARDINAL)
       [MAIL.ATTRIBUTE (RECORD (TYPE MAIL.ATTRIBUTE.TYPE)
                              (VALUE (SEQUENCE UNSPECIFIED]
       [SELECTIONS (RECORD (TRANSPORT.ENVELOPE BOOLEAN)
                          (INBASKET.ENVELOPE BOOLEAN)
                          (MAIL.ATTRIBUTES (SEQUENCE MAIL.ATTRIBUTE.TYPE]
       (CACHE.VERIFIER (ARRAY 4 UNSPECIFIED))
       (MESSAGE.DESCRIPTION (RECORD (MESSAGE.INDEX INDEX)
                                   (TRANSPORT.ENVELOPE ENVELOPE)
                                   (INBASKET.ENVELOPE ENVELOPE)
                                   (CONTENT.ATTRIBUTES ENVELOPE)))
       (CACHE.STATUS UNSPECIFIED)
       (STATUS (ENUMERATION (NEW 0)
                      (KNOWN 1)
                      (RECEIVED 2)))
       (ACCESS.PROBLEM (ENUMERATION (AccessRightsInsufficient 0)
                              (AccessRightsIndeterminate 1)
                              (InbasketInUse 2)
                              (NoSuchRecipients 3)
                              (RecipientNameIndeterminate 4)))
       (CONNECTION.PROBLEM (FILING . CONNECTION.PROBLEM))
       (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0)
                               (ServiceFull 1)
                               (ServiceUnavailable 2)
                               (MediumFull 3)))
       (TRANSFER.PROBLEM (ENUMERATION (Aborted 0)
                                (NoRendezvous 1)
                                (WrongDirection 4)))
       (SESSION.PROBLEM (ENUMERATION (TokenInvalid 0)
                               (SessionInUse 1)))
       (CALL.PROBLEM (ENUMERATION (USE.COURIER 0]
    PROCEDURES
      ((LOGON 5 (CREDENTIALS VERIFIER NAME CACHE.VERIFIER BOOLEAN)
              RETURNS
              (SESSION CACHE.STATUS)
              REPORTS
              (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR UNDEFINED.ERROR))
       (LOGOFF 4 (SESSION)
              RETURNS
              (CACHE.VERIFIER)
              REPORTS
              (AUTHENTICATION.ERROR SESSION.ERROR UNDEFINED.ERROR))
       (MAILPOLL 7 (CREDENTIALS VERIFIER NAME)
              RETURNS
              (INBASKET.STATE)
              REPORTS
              (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR UNDEFINED.ERROR))
       (MAILCHECK 6 (SESSION)
              RETURNS
              (INBASKET.STATE CARDINAL)
              REPORTS
              (ACCESS.ERROR AUTHENTICATION.ERROR SERVICE.ERROR UNDEFINED.ERROR))
       (CHANGE.STATUS 0 (SESSION RANGE STATUS)
              RETURNS NIL REPORTS (AUTHENTICATION.ERROR INVALID.INDEX SESSION.ERROR UNDEFINED.ERROR))
       (DELETE 1 (SESSION RANGE)
              RETURNS NIL REPORTS (AUTHENTICATION.ERROR INVALID.INDEX SESSION.ERROR UNDEFINED.ERROR))
       (LIST 2 (SESSION RANGE SELECTIONS BULK.DATA.SINK)
             RETURNS NIL REPORTS (AUTHENTICATION.ERROR CONNECTION.ERROR INVALID.INDEX SESSION.ERROR 
                                        TRANSFER.ERROR UNDEFINED.ERROR))
       (LOCATE 3 (SESSION STATUS)
              RETURNS
              (INDEX)
              REPORTS
              (AUTHENTICATION.ERROR SESSION.ERROR UNDEFINED.ERROR))
       (RETRIEVE 8 (SESSION INDEX CONTENTS.TYPE BULK.DATA.SINK)
              RETURNS
              (ENVELOPE ENVELOPE)
              REPORTS
              (AUTHENTICATION.ERROR CONNECTION.ERROR CONTENTS.TYPE.MISMATCH INVALID.INDEX 
                     SESSION.ERROR TRANSFER.ERROR UNDEFINED.ERROR)))
    ERRORS
      ((ACCESS.ERROR 0 (ACCESS.PROBLEM))
       (AUTHENTICATION.ERROR 1 ((AUTHENTICATION . PROBLEM)))
       (CONNECTION.ERROR 2 (CONNECTION.PROBLEM))
       (CONTENTS.TYPE.MISMATCH 3 (CONTENTS.TYPE))
       (SESSION.ERROR 5 (SESSION.PROBLEM))
       (INVALID.INDEX 4 (INDEX))
       (SERVICE.ERROR 6 (SERVICE.PROBLEM))
       (TRANSFER.ERROR 7 (TRANSFER.PROBLEM))
       (UNDEFINED.ERROR 8 (CALL.PROBLEM))))
(DEFINEQ

(\NSMAIL.AUTHENTICATE
(LAMBDA NIL (* ; "Edited  5-Jan-90 18:36 by bvm") (LET ((INFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|))) NSUSERNAME FULLNAME MSERVERS AUTHENTICATED? CREDENTIALS MSG) (SETQ NSUSERNAME (PARSE.NSNAME (CAR INFO))) (COND ((NEQ (SETQ AUTHENTICATED? (COND ((NULL (SETQ FULLNAME (CH.LOOKUP.OBJECT NSUSERNAME))) (QUOTE NoSuchUser)) (T (NS.AUTHENTICATE (SETQ CREDENTIALS (NS.MAKE.SIMPLE.CREDENTIALS (CONS FULLNAME (CDR INFO)))))))) T) (printout PROMPTWINDOW T "Cannot authenticate user " (NSNAME.TO.STRING (OR FULLNAME NSUSERNAME) T) " because: " (SELECTQ (SETQ \LAFITE.AUTHENTICATION.FAILURE AUTHENTICATED?) (CredentialsInvalid "Login incorrect") (KeysUnavailable (CONCAT "Authentication server unavailable for domain " (fetch NSDOMAIN of FULLNAME))) (NoSuchUser "No such user") AUTHENTICATED?) ".") NIL) (T (create LAFITEMODEDATA FULLUSERNAME _ (NSNAME.TO.STRING FULLNAME T) UNPACKEDUSERNAME _ FULLNAME CREDENTIALS _ CREDENTIALS SHORTUSERNAME _ (CONCAT (fetch NSOBJECT of FULLNAME) (QUOTE %:) (COND ((NOT (STRING-EQUAL (fetch NSDOMAIN of FULLNAME) CH.DEFAULT.DOMAIN)) (fetch NSDOMAIN of FULLNAME)) (T ""))) MAILSERVERS _ (\NSMAIL.MAKE.MAILSERVERS (NS.FINDMAILBOXES FULLNAME) FULLNAME CREDENTIALS))))))
)

(\NSMAIL.MAKE.MAILSERVERS
(LAMBDA (SERVERS FULLNAME CREDENTIALS) (* ; "Edited 16-Aug-89 16:05 by bvm") (* ;; "Return a list of mail server info for insertion in the MAILSERVERS slot of NS mode.  Each element of SERVERS is of the form (name . addresses)") (if (NULL SERVERS) then (printout PROMPTWINDOW T "There are no mail servers for user " (NSNAME.TO.STRING FULLNAME T)) NIL else (for PAIR in SERVERS bind (FIRSTTIME _ T) collect (create MAILSERVER MAILPORT _ (CADR PAIR) MAILSERVERNAME _ (CAR PAIR) MAILSERVEROPS _ (CONSTANT (LIST (FUNCTION NS.POLLNEWMAIL) (FUNCTION NS.OPENMAILBOX) (FUNCTION NS.NEXTMESSAGE) (FUNCTION NS.RETRIEVEMESSAGE) (FUNCTION NS.CLOSEMAILBOX))) MAILSTATE _ (create NSMAILSTATE STATENAME _ FULLNAME STATEADDRESS _ (CADR PAIR) STATECREDENTIALS _ CREDENTIALS STATETIMER _ (if FIRSTTIME then (* ; "Only need a timer on the first server") (SETQ FIRSTTIME NIL) (SETUPTIMER *NSMAIL-CACHE-TIMEOUT*)))))))
)

(\NSMAIL.LOGIN
(LAMBDA NIL (* ; "Edited  7-Jun-88 19:37 by bvm") (if (LAFITE.PROMPT.FOR.LOGIN (QUOTE |NS::|)) then (* ; "Got the login, now authenticate") (\LAFITE.GET.USER.DATA (QUOTE NS) NIL T) (\LAFITE.WAKE.WATCHER)))
)

(NS.FINDMAILBOXES
(LAMBDA (USERNAME) (* ; "Edited 18-Jul-88 12:55 by bvm") (LET ((MAILBOXENTRY (CH.RETRIEVE.ITEM (PARSE.NSNAME USERNAME) (CH.PROPERTY (QUOTE MAILBOXES)) (QUOTE MAILBOX.VALUES)))) (AND MAILBOXENTRY (for MB in (COURIER.FETCH (CLEARINGHOUSE . MAILBOX.VALUES) MAIL.SERVICE of (CADR MAILBOXENTRY)) when (SETQ MB (COND ((LOOKUP.NS.SERVER MB NIL T)) (T (PRINTOUT PROMPTWINDOW T "Cannot find address for mail server " MB) NIL))) collect MB))))
)
)

(ADDTOVAR LAFITEMODELST (NS 1 \NSMAIL.SEND.PARSE \NSMAIL.SEND \NSMAIL.MAKEANSWERFORM 
                                \NSMAIL.AUTHENTICATE \NSMAIL.MESSAGE.P \NSMAIL.MESSAGE.FROM.SELF.P 
                                \NSMAIL.LOGIN)
                            (STAR . NS))



(* ; "Retrieving mail")

(DEFINEQ

(NS.POLLNEWMAIL
  [LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)(* ; "Edited 26-Jun-90 18:21 by jds")
    (LET (RESULT N)
         (COND
            ((NOT (SETQ RESULT (\NSMAIL.CHECK ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)))
                                                             (* ; "Server down")
             '?)
            ((AND (> (SETQ N (fetch (NSMAILSTATE STATEFIRSTNEW) of (fetch MAILSTATE
                                                                              of MAILSERVER)))
                     0)
                  (> (SETQ N (ADD1 (- (COURIER.FETCH (INBASKET . INBASKET.STATE)
                                             LASTINDEX of RESULT)
                                      N)))
                     0))                                     (* ; "Return number of messages")
             N])

(NS.OPENMAILBOX
  [LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER)(* ; "Edited 26-Jun-90 18:21 by jds")
    (LET ((STREAM (\NSMAIL.COURIER.OPEN ADDRESS))
          NSMAILSTATE INBASKETSTATE FIRSTINDEX LASTINDEX N)
         (COND
            ((NULL STREAM)
             NIL)
            ((OR (NULL (SETQ INBASKETSTATE (\NSMAIL.CHECK ADDRESS REGISTEREDNAME CREDENTIALS 
                                                  MAILSERVER STREAM T)))
                 (EQ (CAR INBASKETSTATE)
                     'ERROR))
             (CLOSEF STREAM)                                 (* ; "Return error msg")
             (CONS NIL (CDR INBASKETSTATE)))
            ((EQ [SETQ N (COND
                            ((EQ [SETQ FIRSTINDEX (fetch (NSMAILSTATE STATEFIRSTNEW)
                                                     of (SETQ NSMAILSTATE (fetch MAILSTATE
                                                                                 of MAILSERVER]
                                 0)                          (* ; "No NEW messages at all")
                             0)
                            (T                               (* ; "Protocol suggests using (courier.fetch (inbasket . inbasket.state) newcount inbasketstate) but that's always zero.")
                               (ADD1 (- (SETQ LASTINDEX (COURIER.FETCH (INBASKET . INBASKET.STATE)
                                                               LASTINDEX of INBASKETSTATE))
                                        FIRSTINDEX]
                 0)
             (\NSMAIL.LOGOFF NSMAILSTATE STREAM)
             'EMPTY)
            (T                                               (* ; "Return (MAILBOX  . properties)")
               (CONS (create NSMAILBOX
                            NSMAILSTREAM _ STREAM
                            NSMAILLASTINDEX _ LASTINDEX
                            NSMAILSTATE _ NSMAILSTATE)
                     (LIST '%#OFMESSAGES N])

(\NSMAIL.CHECK
  [LAMBDA (ADDRESS REGISTEREDNAME CREDENTIALS MAILSERVER STREAM RETURNERRORS)
                                                             (* ; "Edited 26-Jun-90 18:21 by jds")

(* ;;; "Performs a mail check for user REGISTEREDNAME at ADDRESS, returning INBASKETSTATE if successful, NIL if not.  Updates the MAILSTATE of MAILSERVER as appropriate to reflect current SESSION and STATEFIRSTNEW (first new message)")

    (RESETLST
        (PROG ((JUSTCHECKING (NULL STREAM))
               (STATE (fetch (MAILSERVER MAILSTATE) of MAILSERVER))
               SESSION POLLRESULT LASTINDEX FIRSTNEW OLDLAST CONTINUANCE TIMER)
              (COND
                 ((AND JUSTCHECKING (SETQ TIMER (fetch (NSMAILSTATE STATETIMER) of STATE))
                       (TIMEREXPIRED? TIMER)
                       (\NSMAIL.FIX.MAILBOX.LOCATIONS))  (* ; "Some mailboxes moved")
                  (GO FAILFAST)))
              (SETQ SESSION (fetch (NSMAILSTATE STATESESSION) of STATE))
              (SETQ FIRSTNEW (fetch (NSMAILSTATE STATEFIRSTNEW) of STATE))
              (SETQ OLDLAST (fetch (NSMAILSTATE STATEOLDLAST) of STATE))
          RETRY
              [COND
                 ((NULL SESSION)
                  (if (AND (NOT NSMAIL.LEAVE.ATTACHMENTS)
                               JUSTCHECKING)
                      then                               (* ; 
                                                           "Just polling, don't need session")
                            (SETQ POLLRESULT (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET
                                                    'INBASKET
                                                    'MAILPOLL
                                                    (CAR CREDENTIALS)
                                                    (CDR CREDENTIALS)
                                                    (fetch (NSMAILSTATE STATENAME) of STATE)
                                                    'RETURNERRORS))
                            (GO GOTRESULT))
                  [COND
                     ((NULL STREAM)                          (* ; 
                                                  "Need a real Courier stream for some reason here")
                      (COND
                         ((SETQ STREAM (COURIER.OPEN ADDRESS NIL T 'NSMAIL))
                          (RESETSAVE NIL (LIST 'CLOSEF STREAM)))
                         (T (RETURN NIL]
                  (COND
                     ((EQ [CAR (SETQ SESSION (COND
                                                ((OR T STREAM)
                                                             (* ; 
              "Would be nice to do this expedited, but this ability was taken out in Services 8.1!")
                                                 (COURIER.CALL STREAM 'INBASKET 'LOGON (CAR 
                                                                                          CREDENTIALS
                                                                                            )
                                                        (CDR CREDENTIALS)
                                                        (fetch (NSMAILSTATE STATENAME)
                                                           of STATE)
                                                        \NULL.CACHE.VERIFIER T 'RETURNERRORS))
                                                (T (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET
                                                          'INBASKET
                                                          'LOGON
                                                          (CAR CREDENTIALS)
                                                          (CDR CREDENTIALS)
                                                          (fetch (NSMAILSTATE STATENAME)
                                                             of STATE)
                                                          \NULL.CACHE.VERIFIER T 'RETURNERRORS]
                          'ERROR)
                      (GO ERROR)))
                  (replace (NSMAILSTATE STATESESSION) of STATE with (SETQ SESSION
                                                                                 (CAR SESSION]
              [SETQ POLLRESULT (COND
                                  ((NULL STREAM)             (* ; "Just checking")
                                   (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET 'INBASKET
                                          'MAILCHECK SESSION 'RETURNERRORS))
                                  (T (COURIER.CALL STREAM 'INBASKET 'MAILCHECK SESSION 'RETURNERRORS]
          GOTRESULT
              [COND
                 ((NULL POLLRESULT)                          (* ; "Failed somehow")
                  (RETURN NIL))
                 ((EQ (CAR (LISTP POLLRESULT))
                      'ERROR)
                  (COND
                     ((EQ (CADR POLLRESULT)
                          'SESSION.ERROR)                    (* ; 
                                                           "Session timed out, start a new one")
                      (replace (NSMAILSTATE STATESESSION) of STATE with (SETQ SESSION NIL
                                                                                     ))
                      (replace (NSMAILSTATE STATEFIRSTNEW) of STATE with (SETQ FIRSTNEW 
                                                                                      NIL))
                      (replace (NSMAILSTATE STATEOLDLAST) of STATE with (SETQ OLDLAST NIL
                                                                                     ))
                      (GO RETRY))
                     (T (SETQ SESSION POLLRESULT)
                        (GO ERROR]
              (replace (NSMAILSTATE STATELASTERROR) of STATE with NIL)
              (if SESSION
                  then                                   (* ; 
                                               "MAILCHECK returned 2 values: state and continuance")
                        (SETQ CONTINUANCE (CADR POLLRESULT))
                        (SETQ POLLRESULT (CAR POLLRESULT)))
              (COND
                 ((EQ (SETQ LASTINDEX (COURIER.FETCH (INBASKET . INBASKET.STATE)
                                             LASTINDEX of POLLRESULT))
                      0)                                     (* ; "Mailbox is empty")
                  (replace (NSMAILSTATE STATEFIRSTNEW) of STATE with 0))
                 ((NOT NSMAIL.LEAVE.ATTACHMENTS)             (* ; 
                                           "Retrieving all mail, so we don't care about NEW vs OLD")
                  (replace (NSMAILSTATE STATEFIRSTNEW) of STATE with 1)
                  (replace (NSMAILSTATE STATEOLDLAST) of STATE with LASTINDEX))
                 ((OR (NULL OLDLAST)
                      (ILESSP OLDLAST LASTINDEX)
                      (NOT JUSTCHECKING)
                      (NULL FIRSTNEW))                       (* ; 
                                                      "Need to accurately locate first NEW message")
                  [replace (NSMAILSTATE STATEFIRSTNEW) of STATE
                     with (COND
                                 (STREAM (COURIER.CALL STREAM 'INBASKET 'LOCATE SESSION 'NEW
                                                'NOERROR))
                                 (T (COURIER.EXPEDITED.CALL ADDRESS \NSMAIL.SOCKET 'INBASKET
                                           'LOCATE SESSION 'NEW 'RETURNERRORS]
                  (replace (NSMAILSTATE STATEOLDLAST) of STATE with LASTINDEX)))
              [replace (MAILSERVER CONTINUANCE) of MAILSERVER
                 with (AND (FIXP CONTINUANCE)
                               (ITIMES 1000 (IQUOTIENT (ITIMES CONTINUANCE 4)
                                                   5]        (* ; 
                                      "Tell poller to call again soon enough to keep session alive")
              (RETURN POLLRESULT)
          ERROR
              [if [AND [NOT (EQUAL (CDR SESSION)
                                       '(CONNECTION.PROBLEM NoResponse]
                           (NOT (EQUAL (CDR SESSION)
                                       (fetch (NSMAILSTATE STATELASTERROR) of STATE]
                  then 

                        (* ;; "Don't bother mentioning the error if it's just a timeout, since mailwatch will handle our NIL response fine.  Also don't repeatedly print the same error message.")

                        (replace (NSMAILSTATE STATELASTERROR) of STATE with (CDR SESSION)
                               )
                        (LET [(ERRMSG (CASE (CADR SESSION)
                                          ((REJECT)          (* ; "3rd element = (reason ...)")
                                             (CAADDR SESSION))
                                          ((SERVICE.ERROR ACCESS.ERROR) 
                                                             (* ; 
              "the specific reason is just as informative, and more readable than the whole error.")
                                             (CADDR SESSION))
                                          (T (COND
                                                (NSWIZARDFLG (HELP SESSION)))
                                             (SUBSTRING (CDR SESSION)
                                                    2 -2)))]
                             (if RETURNERRORS
                                 then (RETURN (CONS 'ERROR ERRMSG))
                               elseif (AND (EQ ERRMSG 'NoSuchRecipients)
                                               (\NSMAIL.FIX.MAILBOX.LOCATIONS))
                                 then 

                                 (* ;; "Rather odd message.  We get this when the server no longer holds this inbox.  At this point we have fixed mail servers in NS mode, but there's no good way for us to report the news, so go ahead and return NIL, but set %"continuance%" so that poll will happen again immediately")

                                       (replace (MAILSERVER CONTINUANCE) of MAILSERVER
                                          with 0)
                               else (LET ((*PRINT-CASE* :UPCASE))
                                                             (* ; "Lousy atomic error names...")
                                             (CL:FORMAT PROMPTWINDOW "~%%From mail server ~A: ~A"
                                                    (fetch (MAILSERVER MAILSERVERNAME)
                                                       of MAILSERVER)
                                                    (CASE ERRMSG
                                                        (NoSuchService "Mail service not running")
                                                        (T ERRMSG))]
              (RETURN NIL)
          FAILFAST))])

(\NSMAIL.FIX.MAILBOX.LOCATIONS
  [LAMBDA NIL                                            (* ; "Edited 26-Jun-90 18:21 by jds")

    (* ;; "Called when we think user's mailboxes may have moved.  If they have, sets new info into NS mode and returns T.")

    (LET
     ((OLDDATA (\LAFITE.GET.USER.DATA 'NS))
      OLDSERVERS NEWSERVERS FULLNAME)
     (if (AND OLDDATA (SETQ OLDSERVERS (fetch (LAFITEMODEDATA MAILSERVERS) of OLDDATA)))
         then                                            (* ; 
         "Actually, if we got here at all, OLDSERVERS surely is non-NIL.  The check is for sanity.")
         [SETQ NEWSERVERS (NS.FINDMAILBOXES (SETQ FULLNAME (fetch (LAFITEMODEDATA 
                                                                                 UNPACKEDUSERNAME)
                                                                  of OLDDATA]
         [LET [(STATE (fetch (MAILSERVER MAILSTATE) of (CAR OLDSERVERS]
                                                             (* ; 
                                    "Reset the timer that tells us when next to check on location.")
              (replace (NSMAILSTATE STATETIMER) of STATE
                 with (SETUPTIMER (if NEWSERVERS
                                          then *NSMAIL-CACHE-TIMEOUT*
                                        else             (* ; 
                                                           "Couldn't find servers?  Try again soon")
                                              60000)
                                 (fetch (NSMAILSTATE STATETIMER) of STATE]
         (if [AND NEWSERVERS
                      (OR (NOT (EQ (LENGTH NEWSERVERS)
                                   (LENGTH OLDSERVERS)))
                          (for SERVER in OLDSERVERS as PAIR in NEWSERVERS
                             thereis (OR (NOT (EQUAL.CH.NAMES (CAR PAIR)
                                                         (fetch MAILSERVERNAME of SERVER)))
                                             (NOT (for I from 0 to 4
                                                     bind (SERVERADDR _ (fetch MAILPORT
                                                                               of SERVER))
                                                           (PAIRADDR _ (CADR PAIR))
                                                     always (EQ (\GETBASE SERVERADDR I)
                                                                    (\GETBASE PAIRADDR I]
             then 

                   (* ;; "Yes, mailbox info is different.  Fix it up.  Note that we do nothing if no mail servers were found.  This is to avoid screwing up when we failed to talk to a clearinghouse (since otherwise we would find ourselves with no servers, hence nobody to wake up periodically and find out where the servers have moved to).  If only CH.RETRIEVE.ITEM could give us an error return in that case...")

                   (replace (LAFITEMODEDATA MAILSERVERS) of OLDDATA
                      with (\NSMAIL.MAKE.MAILSERVERS NEWSERVERS FULLNAME (fetch
                                                                                  (LAFITEMODEDATA
                                                                                   CREDENTIALS)
                                                                                    of OLDDATA)))
                   T])

(NS.NEXTMESSAGE
  [LAMBDA (MAILBOX)                                      (* ; "Edited 26-Jun-90 18:18 by jds")
    (PROG ((ENVELOPES (fetch (NSMAILBOX NSMAILENVTAIL) of MAILBOX)))
          (SELECTQ ENVELOPES
              (NIL                                           (* ; "First time, read all envelopes")
                   (COND
                      ([OR (fetch (NSMAILBOX NSMAILENVELOPES) of MAILBOX)
                           (NULL (SETQ ENVELOPES (\NSMAIL.READ.ENVELOPES MAILBOX]
                       (RETURN)))
                   (replace (NSMAILBOX NSMAILENVELOPES) of MAILBOX with ENVELOPES)
                   (replace (NSMAILBOX NSMAILENVTAIL) of MAILBOX with ENVELOPES))
              (T                                             (* ; "Finished")
                 (RETURN))
              NIL)
          (RETURN (CAR ENVELOPES])

(\NSMAIL.READ.ENVELOPES
  [LAMBDA (MAILBOX)                                      (* ; "Edited 26-Jun-90 18:19 by jds")
    (LET [(ENVELOPES (INBASKET.CALL MAILBOX 'LIST (fetch (NSMAILBOX NSMAILSESSION)
                                                         of MAILBOX)
                            (COURIER.CREATE (INBASKET . RANGE)
                                   FIRST _ (fetch (NSMAILBOX NSMAILFIRSTINDEX) of MAILBOX)
                                   LAST _ (fetch (NSMAILBOX NSMAILLASTINDEX) of MAILBOX))
                            (COURIER.CREATE (INBASKET . SELECTIONS)
                                   TRANSPORT.ENVELOPE _ T INBASKET.ENVELOPE _ T MAIL.ATTRIBUTES _
                                   (LIST (\NSMAIL.ATTRIBUTE.TYPE BodyType)))
                            '(INBASKET . MESSAGE.DESCRIPTION]
         (for E in ENVELOPES collect (CONS (COURIER.FETCH (INBASKET
                                                                               . MESSAGE.DESCRIPTION)
                                                              MESSAGE.INDEX of E)
                                                       (APPEND (COURIER.FETCH (INBASKET
                                                                               . MESSAGE.DESCRIPTION)
                                                                      CONTENT.ATTRIBUTES of E)
                                                              (COURIER.FETCH (INBASKET
                                                                               . MESSAGE.DESCRIPTION)
                                                                     TRANSPORT.ENVELOPE of E)
                                                              (COURIER.FETCH (INBASKET
                                                                               . MESSAGE.DESCRIPTION)
                                                                     INBASKET.ENVELOPE of E])

(INBASKET.CALL
  [CL:LAMBDA (MAILBOX PROCEDURE &REST ARGS)              (* ; "Edited 26-Jun-90 18:19 by jds")
         (PROG ((STREAM (fetch (NSMAILBOX NSMAILSTREAM) of MAILBOX))
                RESULT)
           LP  (if (AND (EQ [CAR (LISTP (SETQ RESULT (CL:APPLY (FUNCTION COURIER.CALL)
                                                                STREAM
                                                                'INBASKET PROCEDURE ARGS]
                                'ERROR)
                            (CASE (CAR (LAST ARGS))
                                (NOERROR NIL)
                                (RETURNERRORS                (* ; 
                                              "We'll only handle stream lost--caller gets the rest")
                                   (EQ (CADR RESULT)
                                       'STREAM.LOST))
                                (T                           (* ; 
                                                           "Probably an error was already signaled")
                                   T)))
                   then (SETQ STREAM (\NSMAIL.SIGNAL.ERROR RESULT MAILBOX 'INBASKET PROCEDURE
                                                ))
                         (GO LP)
                 else (RETURN RESULT])

(NS.RETRIEVEMESSAGE
  [LAMBDA (MAILBOX MSGOUTFILE)                           (* ; "Edited 26-Jun-90 18:19 by jds")
    (LET ((*RETRIEVAL-ERROR* NIL)
          (ENVELOPE (pop (fetch (NSMAILBOX NSMAILENVTAIL) of MAILBOX)))
          TYPE)
         (if (OR NSMAIL.LEAVE.ATTACHMENTS (MEMB (SETQ TYPE (CADR (ASSOC 'BodyType ENVELOPE)))
                                                    \NSMAIL.GOOD.BODYTYPES))
             then                                        (* ; 
            "Retrieve ordinary text message, or retrieve the text part and leave attachment behind")
                   (\NSMAIL.RETRIEVE MAILBOX ENVELOPE [FUNCTION (LAMBDA (MSGSTREAM)

                                                           (* ;; 
                "MSGSTREAM is a bulk data stream containing content of msg, as a 'serialized file'")

                                                                      (SETFILEINFO
                                                                       MSGSTREAM
                                                                       'ENDOFSTREAMOP
                                                                       (FUNCTION 
                                                                        \NSMAIL.EOF.ON.RETRIEVE))
                                                                      (
                                                                   \NSMAIL.CHECK.SERIALIZED.VERSION
                                                                       MSGSTREAM)
                                                                      (\NSMAIL.READ.SERIALIZED.TREE
                                                                       MSGSTREAM MSGOUTFILE
                                                                       (CDR ENVELOPE]
                          (GETFILEPTR MSGOUTFILE)
                          MSGOUTFILE)
                   (COND
                      (*RETRIEVAL-ERROR* (printout MSGOUTFILE T *RETRIEVAL-ERROR* T)))
           else                                          (* ; 
                "Not text or mail note, so retrieve the whole thing raw and make an %"attachment%"")
                 (SETQ TYPE (\TYPE.FROM.FILETYPE TYPE))
                 (LET ((BUFFER (OPENSTREAM '{NODIRCORE} 'BOTH))
                       BODY ATTACHPOINT ATTRIBUTE.END)
                      [SETQ BODY (\NSMAIL.RETRIEVE
                                  MAILBOX ENVELOPE (FUNCTION (LAMBDA (BULKSTREAM)
                                                             (* ; "Just eat it raw")
                                                               (LET
                                                                [(BODY (OPENSTREAM
                                                                        '{NODIRCORE}
                                                                        'BOTH NIL
                                                                        '((ENDOFSTREAMOP 
                                                                              \NSMAIL.EOF.ON.RETRIEVE
                                                                                 ]
                                                                (COPYBYTES BULKSTREAM BODY)
                                                                BODY]
                      (SETFILEPTR BODY 0)
                      (\NSMAIL.CHECK.SERIALIZED.VERSION BODY)
                      (\NSMAIL.READ.SERIALIZED.TREE BODY BUFFER (CDR ENVELOPE)
                             T)
                      (SETQ ATTRIBUTE.END (GETFILEPTR BODY))
                      (SETQ BUFFER (OPENTEXTSTREAM BUFFER NIL NIL NIL (LIST 'FONT LAFITEDISPLAYFONT))
                       )
                      (TEDIT.INSERT.OBJECT (\MAILOBJ.CREATE BODY TYPE ATTRIBUTE.END)
                             BUFFER
                             (if (SETQ ATTACHPOINT (TEDIT.FIND BUFFER "

Attachment: " 1))
                                 then                    (* ; 
                                                           "Insert object at end of this line")
                                       (+ ATTACHPOINT 14)
                               else                      (* ; "Shouldn't happen")
                                     (+ (TEDIT.FIND BUFFER "

" 1)
                                        2)))
                      (COPYBYTES (OPENSTREAM (COERCETEXTOBJ BUFFER 'FILE)
                                        'INPUT)
                             MSGOUTFILE)                     (* ; 
         "Would like this to be (COERCETEXTOBJ BUFFER (QUOTE FILE) MSGOUTFILE) but Tedit has a bug")
                      ))
         (COND
            ((NEQ (CADR ENVELOPE)
                  'NO)                                       (* ; 
  "Read okay, tell close mailbox to delete it.  NO set when there is an attachment to leave behind")
             (RPLACA (CDR ENVELOPE)
                    'DELETE])

(\NSMAIL.RETRIEVE
  [LAMBDA (MAILBOX ENVELOPE RETRIEVEFN START MSGOUTFILE) (* ; "Edited 26-Jun-90 18:19 by jds")

    (* ;; "Perform an Inbasket.Retrieve on the specified message, using RETRIEVEFN to read the bulk data.  If START is true, then the file pointer on MSGOUTFILE is returned to START if we have to retry")

    (bind RESULT while (EQ [CAR (LISTP (SETQ RESULT (COURIER.CALL (fetch (NSMAILBOX
                                                                                      NSMAILSTREAM)
                                                                             of MAILBOX)
                                                                   'INBASKET
                                                                   'RETRIEVE
                                                                   (fetch (NSMAILBOX 
                                                                                     NSMAILSESSION)
                                                                      of MAILBOX)
                                                                   (CAR ENVELOPE)
                                                                   \NSMAIL.CTSTANDARD.MESSAGE 
                                                                   RETRIEVEFN 'RETURNERRORS]
                                   'ERROR) do            (* ; "Maybe lost the stream?")
                                                 (\NSMAIL.SIGNAL.ERROR RESULT MAILBOX
                                                        'INBASKET
                                                        'RETRIEVE)
                                                 (AND START (SETFILEPTR MSGOUTFILE START))
       finally (RETURN RESULT])

(\NSMAIL.EOF.ON.RETRIEVE
(LAMBDA (STREAM) (DECLARE (USEDFREE *RETRIEVAL-ERROR*)) (* ; "Edited  9-Sep-88 12:29 by bvm") (SETQ *RETRIEVAL-ERROR* "**Warning: errors in message format**") (COND (LAFITEDEBUGFLG (HELP "EOF during retrieve"))) (LET (POS) (COND ((SETQ POS (STKPOS (FUNCTION \NSMAIL.READ.SERIALIZED.TREE))) (RETFROM POS NIL T)) (T 0))))
)

(\NSMAIL.READ.SERIALIZED.TREE
(LAMBDA (MSGSTREAM MSGOUTFILE ENVELOPE ATTACHMENT) (* ; "Edited 17-Jan-89 17:30 by bvm") (* ;;; "Read a message, which is in the format of a NS Filing Serialized File.  This is the recursive part, SerializedTree.  Format is --- Sequence of Attribute;  Content;  children = Sequence of SerializedTree") (PROG (TYPE VALUE HEADERFIELDS LENGTH NOTEBODY HEADERS SENDER TYPEINFO DISCARDED COERCED FORMATSTREAM BODYSTREAM) (for N from (\WIN MSGSTREAM) to 1 by -1 do (SETQ TYPE (COURIER.READ MSGSTREAM NIL (QUOTE LONGCARDINAL))) (COND ((NOT (find old TYPEINFO in \NSMAIL.ATTRIBUTES suchthat (EQ (CADR TYPEINFO) TYPE))) (* ; "We don't understand this attribute") (if (AND NSMAILDEBUGFLG (NOT ATTACHMENT)) then (push DISCARDED TYPE)) (COURIER.SKIP.SEQUENCE MSGSTREAM NIL (QUOTE UNSPECIFIED))) ((EQ (SETQ TYPE (CAR TYPEINFO)) (QUOTE Note)) (* ;; "This is a star mail note.  Treat as body of message.  If it isn't the last attribute, save it for the end") (COND ((NEQ N 1) (COND (NOTEBODY (TERPRI NOTEBODY)) (T (SETQ NOTEBODY (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))))) (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM NOTEBODY)) (T (\NSMAIL.PRINT.HEADERFIELDS MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NOTEBODY ATTACHMENT DISCARDED) (* ; "Print accumulated header fields") (TERPRI MSGOUTFILE) (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM MSGOUTFILE) (RETURN)))) ((OR (EQ TYPE (QUOTE LispFormatting)) (EQ TYPE (QUOTE OldLispFormatting))) (* ; "Note that this MUST be the last attribute") (COND ((EQ N 1) (* ; "Save the formatting so we can munge it") (SETQ FORMATSTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM FORMATSTREAM) (RETURN)) (T (PRINTOUT PROMPTWINDOW T "Bad formatted message") (\NSMAIL.READ.STRING.AS.STREAM MSGSTREAM (OPENSTREAM (QUOTE {NULL}) (QUOTE OUTPUT)))))) (T (SETQ VALUE (PROGN (\WIN MSGSTREAM) (COURIER.READ MSGSTREAM (QUOTE MAILTRANSPORT) (CADDR TYPEINFO)))) (COND ((SELECTQ TYPE ((BodyType BodySize) NIL) (Sender (SETQ SENDER VALUE)) (From (COND ((AND (NULL SENDER) (NULL (CDR VALUE))) (SETQ SENDER (CAR VALUE)))) T) T) (push HEADERFIELDS (CONS TYPE VALUE)))))) finally (* ; "Note was not the final attribute.  Print headers accumulated, then the Note last") (\NSMAIL.PRINT.HEADERFIELDS MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NOTEBODY ATTACHMENT DISCARDED)) (COND (FORMATSTREAM (* ; "This is a TEdit formatted message") (LET ((START (GETFILEPTR MSGOUTFILE))) (\NSMAIL.PRINT.HEADERFIELDS MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NIL ATTACHMENT DISCARDED) (TERPRI MSGOUTFILE) (* ; "We have now printed the header and a blank line.  This is all the added text we have, not counted in the formatting") (SETQ START (- (GETFILEPTR MSGOUTFILE) START)) (if NOTEBODY then (COPYBYTES NOTEBODY MSGOUTFILE 0 -1) (if (NULL ATTACHMENT) then (* ; "There better be nothing more here.  In case of attachment, caller is handling it separately") (\NSMAIL.DISCARD.SERIALIZED.CONTENT MSGSTREAM)) else (* ; "One or the other of these clauses (never both) produced the body of the message, to which the formatting applies.") (\NSMAIL.READ.SERIALIZED.CONTENT MSGSTREAM MSGOUTFILE)) (LA.ADJUST.FORMATTING FORMATSTREAM MSGOUTFILE START) (if (NULL ATTACHMENT) then (* ; "Have to get past the children.  This better be null") (RPTQ (\WIN MSGSTREAM) (to (\WIN MSGSTREAM) do (* ; "Read and discard an attribute...") (COURIER.READ MSGSTREAM NIL (QUOTE LONGCARDINAL)) (COURIER.SKIP.SEQUENCE MSGSTREAM NIL (QUOTE UNSPECIFIED))))))) ((NULL ATTACHMENT) (* ; "No formatting, possibly read body now") (TERPRI MSGOUTFILE) (* ; "Set off header") (COND ((EQ (CAR ENVELOPE) (QUOTE NO)) (* ; "Can't read this attachment, leave in mailbox") (printout MSGOUTFILE T T "*** Attachment retained in mailbox for retrieval by other means ***" T) (COURIER.ABORT.BULKDATA))) (\NSMAIL.READ.SERIALIZED.CONTENT MSGSTREAM MSGOUTFILE) (RPTQ (\WIN MSGSTREAM) (* ; "Read children") (\NSMAIL.READ.SERIALIZED.TREE MSGSTREAM MSGOUTFILE))))))
)

(\NSMAIL.CHECK.SERIALIZED.VERSION
(LAMBDA (STREAM) (* ; "Edited  5-May-89 14:47 by bvm") (LET ((V (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL)))) (SELECTC V (\SERIALIZED.FILE.VERSIONS T) (HELP (CL:FORMAT NIL "Lafite does not understand serialized file version ~D.
RETURN to attempt retrieval anyway." V))))))

(\NSMAIL.READ.SERIALIZED.CONTENT
(LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited 17-Jan-89 17:14 by bvm") (* ;;; "Interprets INSTREAM as SerializedTree.Content, i.e., as a Bulkdata.StreamOfUnspecified followed by the lastByteIsSignificant flag.  Copies the raw data therein to OUTSTREAM") (bind LASTSEGMENT? BYTE BYTECOUNT do (SETQ LASTSEGMENT? (NEQ (\WIN INSTREAM) 0)) (COND ((NEQ (SETQ BYTECOUNT (UNFOLD (\WIN INSTREAM) BYTESPERWORD)) 0) (RPTQ (SUB1 BYTECOUNT) (\BOUT OUTSTREAM (\BIN INSTREAM))) (SETQ BYTE (\BIN INSTREAM)) (* ; "Final byte of this segment.  Don't copy until we know whether it's significant") (COND ((OR (NULL LASTSEGMENT?) (NEQ (\WIN INSTREAM) 0)) (* ; "Not last segment, or the word after says the final byte was significant") (\BOUT OUTSTREAM BYTE)))) (LASTSEGMENT? (* ; "Null body.  Throw out the lastByteIsSignificant flag") (\WIN INSTREAM))) repeatuntil LASTSEGMENT?))
)

(\NSMAIL.DISCARD.SERIALIZED.CONTENT
(LAMBDA (INSTREAM) (* ; "Edited 17-Jan-89 17:17 by bvm") (* ;;; "Interprets INSTREAM as SerializedTree.Content, i.e., as a Bulkdata.StreamOfUnspecified followed by the lastByteIsSignificant flag and discards it all") (do (if (NEQ (PROG1 (\WIN INSTREAM) (RPTQ (UNFOLD (\WIN INSTREAM) BYTESPERWORD) (\BIN INSTREAM))) 0) then (* ; "Finished.  Read the lastByteIsSignificant flag") (\WIN INSTREAM) (RETURN))))
)

(\NSMAIL.READ.STRING.AS.STREAM
(LAMBDA (INSTREAM OUTSTREAM) (* bvm%: "30-Jul-84 16:13") (* ;; "Considers INSTREAM to be positioned at a sequence of unspecified, and reads it as if its datatype were string, and copies said bytes to OUTSTREAM") (PROG (LENGTH) (\WIN INSTREAM) (* ; "Skip sequence count") (COPYBYTES INSTREAM OUTSTREAM (SETQ LENGTH (\WIN INSTREAM))) (COND ((ODDP LENGTH) (\BIN INSTREAM)))))
)

(\NSMAIL.PRINT.HEADERFIELDS
(LAMBDA (MSGOUTFILE HEADERFIELDS ENVELOPE SENDER NOTEBODY ATTACHMENT DISCARDED) (* ; "Edited  4-Aug-89 18:34 by bvm") (* ;; "Compose message header from HEADERFIELDS and ENVELOPE, printing to MSGOUTFILE.  SENDER is the %"Sender%" field of the message, if we encountered one, or sole element of the %"From%" field.  NOTEBODY if non-NIL is a stream containing the text of a Note attribute.  if ATTACHMENT is true, we add a line %"Attachment:%" to the message where caller will later insert the attachment object.  DISCARDED is list of fields we didn't recognize.") (LET (TYPE BADNAMES REASON TMP VALUE ID) (SETQ HEADERFIELDS (REVERSE HEADERFIELDS)) (COND (ENVELOPE (if (SETQ VALUE (ASSOC (QUOTE TransportProblem) ENVELOPE)) then (* ; "Return of undeliverable mail") (SETQ HEADERFIELDS (DREMOVE VALUE HEADERFIELDS)) (SETQ VALUE (CADR VALUE)) (* ; "VALUE is (invalidNames envelope)") (PRINTOUT MSGOUTFILE "Date: " (GDATE (COURIER.FETCH (MAILTRANSPORT . POSTMARK) TIME of (CADR (ASSOC (QUOTE Postmark) ENVELOPE))) (DATEFORMAT TIME.ZONE)) T "From: " (NSNAME.TO.STRING (CADR (ASSOC (QUOTE Originator) ENVELOPE)) T) T "Subject: Undeliverable mail" T T) (SETQ BADNAMES (COURIER.FETCH (MAILTRANSPORT . PROBLEM) UNDELIVERABLES of VALUE)) (SETQ REASON (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) REASON of (CAR BADNAMES))) (PRINTOUT MSGOUTFILE "This message could not be delivered to ") (if (NULL (CDR BADNAMES)) then (PRINTOUT MSGOUTFILE (NSNAME.TO.STRING (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) NAME of (CAR BADNAMES)) T) " because: " REASON T) else (PRINTOUT MSGOUTFILE "the following recipients") (if (for PAIR in (CDR BADNAMES) always (EQ (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) REASON of PAIR) REASON)) then (* ; "Same reason for all") (PRINTOUT MSGOUTFILE " because: " REASON) (for PAIR in BADNAMES bind (SEPR _ ": ") do (PRINTOUT MSGOUTFILE SEPR (NSNAME.TO.STRING (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) NAME of PAIR) T)) (SETQ SEPR ", ") finally (TERPRI MSGOUTFILE)) else (PRINTOUT MSGOUTFILE ":" T) (for PAIR in BADNAMES do (PRINTOUT MSGOUTFILE (NSNAME.TO.STRING (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) NAME of PAIR) T) " because: " (COURIER.FETCH (MAILTRANSPORT . INVALID.NAME) REASON of PAIR) T)))) (PRINTOUT MSGOUTFILE T "- - - - - - - - -" T) (for PAIR in (CADR VALUE) do (* ; "Replace envelope of remaining message with returned envelope") (if (SETQ TMP (ASSOC (CAR PAIR) ENVELOPE)) then (RPLACD TMP (CDR PAIR)) else (push HEADERFIELDS PAIR)))) (* ;; "Prescan HEADERFIELDS to see if there is any additional info we should supply that wasn't in the message") (for PAIR in ENVELOPE do (SETQ VALUE (CADR PAIR)) (SELECTQ (SETQ TYPE (CAR PAIR)) ((PreviousRecipients) (push HEADERFIELDS (CONS TYPE VALUE))) (Postmark (COND ((NULL (ASSOC (QUOTE Date) HEADERFIELDS)) (push HEADERFIELDS (CONS (QUOTE Date) (COURIER.FETCH (MAILTRANSPORT . POSTMARK) TIME of VALUE)))))) (Originator (COND ((NOT (AND SENDER (EQUAL.CH.NAMES SENDER VALUE))) (* ; "The agent that sent the message is not the same as what the header gives as Sender/From.") (push HEADERFIELDS (CONS (if (ASSOC (QUOTE Sender) HEADERFIELDS) then (* ; "There's already a Sender field, so leave it as Originator") (QUOTE Originator) else (QUOTE Sender)) VALUE))))) (BodyType (COND ((AND (NOT ATTACHMENT) (NOT (MEMB VALUE \NSMAIL.GOOD.BODYTYPES))) (NCONC1 HEADERFIELDS (CONS (QUOTE Attachment) VALUE))))) (Message-ID (SETQ ID VALUE)) NIL)))) (for PAIR in (SORT HEADERFIELDS (FUNCTION (LAMBDA (X Y) (* ;; "X sorts before Y if X is in the well-known order and either Y appears after it or doesn't appear at all.") (AND (SETQ X (FMEMB (CAR X) NSMAIL.HEADER.ORDER)) (OR (FMEMB (CAR Y) X) (NULL (FMEMB (CAR Y) NSMAIL.HEADER.ORDER))))))) when (SETQ VALUE (CDR PAIR)) do (printout MSGOUTFILE (SETQ TYPE (CAR PAIR)) ": ") (CASE TYPE (Date (printout MSGOUTFILE (GDATE VALUE (DATEFORMAT NO.SECONDS TIME.ZONE SPACES)))) ((From To cc Reply-to) (\NSMAIL.PRINT.NAMES VALUE MSGOUTFILE (SELECTQ TYPE (From (* ; "Always fully qualified.  Also check against sender.") (if (AND SENDER (NOT (for NAME in VALUE always (OR (EQ NAME SENDER) (AND (STRING-EQUAL (fetch NSDOMAIN of NAME) (fetch NSDOMAIN of SENDER)) (STRING-EQUAL (fetch NSORGANIZATION of NAME) (fetch NSORGANIZATION of SENDER))))))) then (* ; "Ugh, From and Sender are different domains.  To reduce confusion, force everything to be fully qualified") (SETQ SENDER NIL)) NIL) (Reply-to (* ; "always full-qualified") NIL) SENDER))) ((Sender Originator) (printout MSGOUTFILE (NSNAME.TO.STRING VALUE T))) (Attachment (printout MSGOUTFILE "%"Type " |.I1| VALUE " ID " |.P2| ID "%"") (RPLACA ENVELOPE (QUOTE NO))) (T (while (AND (> (NCHARS VALUE) 0) (EQ (NTHCHARCODE VALUE -1) (CHARCODE CR))) do (* ; "Trailing cr's, e.g., in the Subject line, will cause the header not to parse") (SETQ VALUE (SUBSTRING VALUE 1 -2))) (if (STRPOS "
" VALUE) then (* ; "Internal CR?  I suppose we could print it and make sure there is whitespace at the start of the next line, but why bother?") (SETQ VALUE (CL:SUBSTITUTE #\\ #\Newline VALUE))) (PRIN1 VALUE MSGOUTFILE))) (TERPRI MSGOUTFILE)) (if DISCARDED then (printout MSGOUTFILE "Discarded-Fields: ") (LA.PRINT.COMMA.LIST (REVERSE DISCARDED) MSGOUTFILE) (TERPRI MSGOUTFILE)) (COND (ATTACHMENT (* ; "Reserve a line where the attachment object will be placed.") (PRINTOUT MSGOUTFILE T "Attachment: " T))) (COND (NOTEBODY (TERPRI MSGOUTFILE) (COPYBYTES NOTEBODY MSGOUTFILE 0 -1) (TERPRI MSGOUTFILE)))))
)

(\NSMAIL.PRINT.NAMES
(LAMBDA (NSNAMES OUTSTREAM DEFAULTNAME) (* ; "Edited  5-Jan-90 18:30 by bvm") (for NAME in NSNAMES bind (FIRSTTIME _ T) ORGDIFFERS do (COND (FIRSTTIME (SETQ FIRSTTIME NIL)) (T (PRIN3 ", " OUTSTREAM))) (PRIN3 (fetch NSOBJECT of NAME) OUTSTREAM) (LET ((ORG (fetch NSORGANIZATION of NAME)) (DOM (fetch NSDOMAIN of NAME))) (if (OR (SETQ ORGDIFFERS (NOT (AND DEFAULTNAME (OR (STRING-EQUAL ORG (fetch NSORGANIZATION of DEFAULTNAME)) (EQ (NCHARS ORG) 0))))) (NOT (OR (STRING-EQUAL DOM (fetch NSDOMAIN of DEFAULTNAME)) (EQ (NCHARS DOM) 0)))) then (* ;; "Have to print the domain.  The null string tests are because there exists buggy software that doesn't fill in the domain and org--we want them to default correctly eventually.") (PRIN3 ":" OUTSTREAM) (PRIN3 DOM OUTSTREAM) (if ORGDIFFERS then (* ; "Have to print the org, too") (PRIN3 ":" OUTSTREAM) (PRIN3 ORG OUTSTREAM))))))
)
)



(* ; "Error handling")

(DEFINEQ

(\NSMAIL.COURIER.OPEN
(LAMBDA (ADDRESS) (* ; "Edited  9-Sep-88 12:06 by bvm") (COURIER.OPEN ADDRESS NIL T (QUOTE NSMAIL) NIL (CONSTANT (LIST (QUOTE ERRORHANDLER) (FUNCTION \NSMAIL.ERRORHANDLER)))))
)

(\NSMAIL.ERRORHANDLER
(LAMBDA (STREAM ERRCODE) (* ; "Edited  9-Sep-88 12:35 by bvm") (* ;; "Called when SPP error occurs on NS mail courier connection STREAM.  Fakes an error return from the courier.call.") (LET (POS) (if (AND (EQ ERRCODE (QUOTE STREAM.LOST)) (SETQ POS (STKPOS (FUNCTION COURIER.CALL)))) then (BLOCK 500) (RETFROM POS (QUOTE (ERROR STREAM.LOST)) T) else (\SPP.DEFAULT.ERRORHANDLER STREAM ERRCODE))))
)

(\NSMAIL.SIGNAL.ERROR
  [LAMBDA (ERROR MAILBOX PROGRAM PROCEDURE)              (* ; "Edited 26-Jun-90 18:19 by jds")

    (* ;; "Called when we get an error on an NS mail courier call.  If stream lost, then tries to reestablish the connection, returning a new stream on success.")

    (if (EQ (CADR ERROR)
                'STREAM.LOST)
        then (PRINTOUT PROMPTWINDOW T "Lost NS mail connection, trying to reestablish...")
              (LET [(STREAM (\NSMAIL.COURIER.OPEN (create NSADDRESS
                                                         using (SPP.DESTADDRESS
                                                                    (fetch (NSMAILBOX 
                                                                                      NSMAILSTREAM)
                                                                       of MAILBOX))
                                                               NSSOCKET _ 0]
                   (if STREAM
                       then (PRINTOUT PROMPTWINDOW "done.")
                             (replace (NSMAILBOX NSMAILSTREAM) of MAILBOX with STREAM)
                     else (PRINTOUT PROMPTWINDOW "failed.")
                           (ERROR "NS mail connection lost, can't reestablish")))
      else (COURIER.SIGNAL.ERROR PROGRAM PROCEDURE ERROR])
)



(* ; "Close/flush protocol")

(DEFINEQ

(NS.CLOSEMAILBOX
  [LAMBDA (MAILBOX FLUSH?)                               (* ; "Edited 26-Jun-90 18:19 by jds")
    [COND
       (FLUSH?                                               (* ; 
                                                           "Mark everything either deleted or seen")
              (for E in (fetch (NSMAILBOX NSMAILENVELOPES) of MAILBOX)
                 bind START STATUS do [COND
                                                 ((NEQ (CADR E)
                                                       STATUS)
                                                  (COND
                                                     (START (\NSMAIL.CHANGE.STATUS
                                                             MAILBOX START (SUB1 (CAR E))
                                                             STATUS)))
                                                  (SETQ START (CAR E))
                                                  (SETQ STATUS (CADR E]
                 finally (COND
                                (START (\NSMAIL.CHANGE.STATUS MAILBOX START (fetch
                                                                                 (NSMAILBOX 
                                                                                      NSMAILLASTINDEX
                                                                                        )
                                                                                   of MAILBOX)
                                              STATUS]
    (\NSMAIL.LOGOFF (fetch (NSMAILBOX NSMAILSTATE) of MAILBOX)
           (fetch (NSMAILBOX NSMAILSTREAM) of MAILBOX])

(\NSMAIL.LOGOFF
  [LAMBDA (STATE STREAM)                                 (* ; "Edited 26-Jun-90 18:22 by jds")

    (* ;; "Executes the Inbasket.Logoff procedure and clears appropriate state.  Returns true if LOGOFF call succeeded.")

    (LET [(RESULT (COURIER.CALL STREAM 'INBASKET 'LOGOFF (fetch (NSMAILSTATE STATESESSION)
                                                            of STATE)
                         'RETURNERRORS]
         (PROG1 (AND (LISTP RESULT)
                     (NEQ (CAR RESULT)
                          'ERROR))
             (replace (NSMAILSTATE STATESESSION) of STATE with NIL)

             (* ;; "Once session is closed, can't say anything about first new message if there are any messages left, because someone in the meantime could delete them from another session")

             (replace (NSMAILSTATE STATEFIRSTNEW) of STATE with NIL)
             (replace (NSMAILSTATE STATEOLDLAST) of STATE with NIL)
             (CLOSEF STREAM))])

(\NSMAIL.CHANGE.STATUS
  [LAMBDA (MAILBOX START END STATUS)                     (* ; "Edited 26-Jun-90 18:19 by jds")

(* ;;; "Change status of messages START thru END to be STATUS, which is either DELETE or KEEP.  Returns number of messages kept")

    (PROG ((SESSION (fetch (NSMAILBOX NSMAILSESSION) of MAILBOX))
           (STREAM (fetch (NSMAILBOX NSMAILSTREAM) of MAILBOX))
           (RANGE (COURIER.CREATE (INBASKET . RANGE)
                         FIRST _ START LAST _ END)))
          (RETURN (COND
                     ((EQ STATUS 'DELETE)
                      (COURIER.CALL STREAM 'INBASKET 'DELETE SESSION RANGE)
                      0)
                     (T (COURIER.CALL STREAM 'INBASKET 'CHANGE.STATUS SESSION RANGE 'KNOWN)
                        (ADD1 (IDIFFERENCE END START])
)

(RPAQ? NSMAILDEBUGFLG )

(RPAQ? NSMAIL.LEAVE.ATTACHMENTS )

(RPAQ? NSMAIL.HEADER.ORDER '(Date Sender From Subject In-Reply-to To cc Message-ID Reply-to))

(ADDTOVAR \NSMAIL.GOOD.BODYTYPES 2 4)



(* ; "Handling attachments as a special kind of image object")

(DEFINEQ

(\MAILOBJ.CREATE
(LAMBDA (DATA TYPE ATTR.LENGTH NAME MORE.INFO START) (* ; "Edited 14-Feb-90 16:59 by bvm") (* ;; "Create a mail object encapsulating data (a core file in serialized file format).  TYPE is the type of the serialized data.") (OR START (SETQ START 0)) (LET* ((TITLE (SELECTQ TYPE (REFERENCE (* ; "Reference to a file.") (if (NOT MORE.INFO) then (* ; "Try parsing the reference info--returns (REFERENCE info)") (LET* ((INFO (CADR (\MAILOBJ.PARSE.ATTRIBUTES DATA (LIST MAILOBJ.REFERENCE.FIELD) START))) (TYPE (\TYPE.FROM.FILETYPE (CADR (ASSOC (QUOTE TYPE) INFO))))) (SETQ NAME (\MAILOBJ.NS.TO.LISP.NAME (CADR (ASSOC (QUOTE HOST) INFO)) (CADR (ASSOC (QUOTE DIRECTORY) INFO)) (CADR (ASSOC (QUOTE NAME) INFO)) (AND (NEQ (CADR (ASSOC (QUOTE FLAGS) INFO)) \MAILOBJ.REFERENCE.LAST.FILED) (CADR (ASSOC (QUOTE VERSION) INFO))) (EQ TYPE (QUOTE DIRECTORY)))) (SETQ MORE.INFO (BQUOTE (FILE.ID (\, (CADR (ASSOC (QUOTE FILE.ID) INFO))) TYPE (\, TYPE)))))) (CL:FORMAT NIL "Reference to ~A ~A" (\MAILOBJ.TYPE.NAME (LISTGET MORE.INFO (QUOTE TYPE))) NAME)) (if NAME then (CONCAT NAME " (" (\MAILOBJ.TYPE.NAME TYPE T) ")") else (\MAILOBJ.TYPE.NAME TYPE)))) (TITLELEN (NCHARS TITLE)) (FONT (AND (> TITLELEN 20) (LET* ((FONT DEFAULTICONFONT) (SIZE (FONTPROP FONT (QUOTE SIZE)))) (* ; "Use a smaller font if available") (if (> TITLELEN 30) then (* ; "This is really getting out of hand...") (SETQ TITLE (CONCAT (SUBSTRING TITLE 1 25) "..."))) (AND (> SIZE 8) (CAR (NLSETQ (FONTCOPY FONT (QUOTE SIZE) (- SIZE 2)))))))) (IMAGE (WINDOWPROP (TITLEDICONW NIL TITLE FONT (QUOTE (0 . 0)) T NIL (QUOTE FILE)) (QUOTE ICONIMAGE)))) (* ; "Crude way of getting a bitmap with some text printed on it nicely") (IMAGEOBJCREATE (create MAILOBJ MAILOBJ.IMAGE _ IMAGE MAILOBJ.BOX _ (create IMAGEBOX XSIZE _ (BITMAPWIDTH IMAGE) YSIZE _ (BITMAPHEIGHT IMAGE) YDESC _ (LRSH (BITMAPHEIGHT IMAGE) 1) XKERN _ 0) MAILOBJ.TYPE _ TYPE MAILOBJ.DATA _ DATA MAILOBJ.ATTR.LENGTH _ ATTR.LENGTH MAILOBJ.START _ START MAILOBJ.NAME _ NAME MAILOBJ.INFO _ MORE.INFO MAILOBJ.EXPANDABLE _ (PROGN (* ; "True if object has children") (CADR (\MAILOBJ.PARSE.ATTRIBUTES DATA (CONSTANT (LIST (ASSOC (QUOTE IS.DIRECTORY) \NSFILING.ATTRIBUTES))) START)))) \MAILOBJ.IMAGEFNS)))
)

(\MAILOBJ.TYPE.NAME
(LAMBDA (TYPE SHORT) (* ; "Edited 29-Sep-87 14:21 by bvm:") (* ;; "Translate filing TYPE into a descriptive string, e.g., %"Interpress Document%".  If SHORT is true, leave out %"Document%".  If TYPE is numeric, it is rendered as %"Type nnn Document%".") (if (EQ TYPE (QUOTE DIRECTORY)) then (* ; "Viewpoint calls these %"folders%"") "Viewpoint Folder" else (CL:FORMAT NIL "~:[~:(~A~)~;Type ~D~]~@[ Document~]" (FIXP TYPE) TYPE (NOT SHORT))))
)

(\MAILOBJ.NS.TO.LISP.NAME
(LAMBDA (HOST DIRECTORY NAME VERSION DIRECTORYFLG) (* ; "Edited 29-Sep-87 17:54 by bvm:") (* ;; "Turn these pieces parsed out of a reference icon into a Lisp-style file name.  Mainly this means turning the slashes into angles.  This code is stolen from \NSFILING.FULLNAME, which is what we would use if it didn't require a filing session arg.") (LET ((PATHNAME (if DIRECTORYFLG then (CONCAT DIRECTORY "/" NAME (if (AND VERSION (NEQ VERSION 1)) then (CONCAT "!" VERSION) else "")) else DIRECTORY)) FILENAME DIRLST FULLNAME FUNNYCHAR DOTSEEN QUOTEDDIRS) (for I from 1 bind CH (START _ 1) while (SETQ CH (NTHCHARCODE PATHNAME I)) do (SELCHARQ CH (%' (* ; "quote mark, skip it and next char") (add I 1)) (/ (* ; "Directory marker") (push DIRLST (SUBSTRING PATHNAME START (SUB1 I))) (SETQ START (ADD1 I))) ((; %: < > } %]) (* ; "Funny characters that filing doesn't care about but we do -- need to quote these") (SETQ FUNNYCHAR T)) NIL) finally (push DIRLST (SUBSTRING PATHNAME START))) (* ;; "DIRLST is in reverse order now.") (for DIR in DIRLST do (push QUOTEDDIRS (COND (FUNNYCHAR (\NSFILING.ADDQUOTES DIR T)) (T DIR)) (QUOTE >))) (CONCATLIST (NCONC (LIST (QUOTE {) HOST "}<") QUOTEDDIRS (AND (NOT DIRECTORYFLG) (CONS (\NSFILING.ADDQUOTES NAME) (AND VERSION (LIST (if (STRPOS "." NAME) then ";" else ".;") VERSION))))))))
)

(\MAILOBJ.DISPLAY
  [LAMBDA (OBJ STREAM)                                   (* ; "Edited 26-Jun-90 18:17 by jds")
    (LET [(IMAGE (fetch (MAILOBJ MAILOBJ.IMAGE) of (fetch OBJECTDATUM of OBJ]
                                                             (* ; 
                                                      "Display the image, centered on the baseline")
         (BITBLT IMAGE NIL NIL STREAM (DSPXPOSITION NIL STREAM)
                (- (DSPYPOSITION NIL STREAM)
                   (LRSH (BITMAPHEIGHT IMAGE)
                         1])

(\MAILOBJ.GET
(LAMBDA (STREAM TEXTSTREAM) (* ; "Edited 14-Feb-90 16:50 by bvm") (DESTRUCTURING-BIND (LEN TYPE ATTR.LEN NAME . INFO) (READ STREAM FILERDTBL) (LET (DATASTREAM START) (if (EQ (fetch DEVICENAME of (fetch (STREAM DEVICE) of STREAM)) (QUOTE NODIRCORE)) then (* ; "No need to copy the data, just copy the cover") (SETQ DATASTREAM (NCREATE (QUOTE STREAM) STREAM)) (SETQ START (GETFILEPTR STREAM)) (LET ((EOF (+ START LEN))) (* ; "Fix the eof so we don't have to carry around the length") (replace (STREAM EPAGE) of DATASTREAM with (FOLDLO EOF BYTESPERPAGE)) (replace (STREAM EOFFSET) of DATASTREAM with (IMOD EOF BYTESPERPAGE))) else (SETQ DATASTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (COPYBYTES STREAM DATASTREAM LEN) (SETQ START 0)) (\MAILOBJ.CREATE DATASTREAM TYPE ATTR.LEN NAME INFO START))))
)

(\MAILOBJ.IMAGEBOX
  [LAMBDA (OBJ)                                          (* ; "Edited 26-Jun-90 18:17 by jds")
    (fetch (MAILOBJ MAILOBJ.BOX) of (fetch OBJECTDATUM of OBJ])

(\MAILOBJ.PUT
  [LAMBDA (OBJ STREAM)                                   (* ; "Edited 26-Jun-90 18:17 by jds")
    (LET* ((MAILOBJ (fetch OBJECTDATUM of OBJ))
           (COREFILE (fetch (MAILOBJ MAILOBJ.DATA) of MAILOBJ))
           (END (GETEOFPTR COREFILE))
           (START (fetch (MAILOBJ MAILOBJ.START) of MAILOBJ)))
          (LET ((*PRINT-BASE* 10)
                (*READTABLE FILERDTBL)
                (NAME (fetch (MAILOBJ MAILOBJ.NAME) of MAILOBJ))
                (INFO (fetch (MAILOBJ MAILOBJ.INFO) of MAILOBJ)))
                                                             (* ; "Make sure we can read it back.")
               (PRIN4 (LIST* (- END START)
                             (fetch (MAILOBJ MAILOBJ.TYPE) of MAILOBJ)
                             (fetch (MAILOBJ MAILOBJ.ATTR.LENGTH) of MAILOBJ)
                             (AND (OR NAME INFO)
                                  (CONS NAME INFO)))
                      STREAM))
          (COPYBYTES COREFILE STREAM START END])

(\MAILOBJ.INIT
(LAMBDA NIL (* ; "Edited 29-Jun-87 16:36 by bvm:") (SETQ \MAILOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION \MAILOBJ.DISPLAY) (FUNCTION \MAILOBJ.IMAGEBOX) (FUNCTION \MAILOBJ.PUT) (FUNCTION \MAILOBJ.GET) (FUNCTION CL:IDENTITY) (FUNCTION \MAILOBJ.BUTTONEVENTFN))))
)
)
(DEFINEQ

(\MAILOBJ.BUTTONEVENTFN
  [LAMBDA (OBJ WINDOWSTREAM SELECTION RELX RELY WINDOW TEXTSTREAM BUTTON)
                                                             (* ; "Edited 26-Jun-90 18:17 by jds")
    (if (.COPYKEYDOWNP.)
        then                                             (* ; 
                                                         "There's more to copy selection than this")
              [AND NIL (LET [(NAME (fetch (MAILOBJ MAILOBJ.NAME) of (IMAGEOBJPROP
                                                                             OBJ
                                                                             'OBJECTDATUM]
                            (AND NAME (BKSYSBUF NAME]
      elseif (IMAGEOBJPROP OBJ 'BUSY)
        then                                             (* ; "Busy")
              (PRINTOUT PROMPTWINDOW T "Attachment is busy")
      else
      (LET*
       [(MAILOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM))
        (TYPE (fetch (MAILOBJ MAILOBJ.TYPE) of MAILOBJ))
        (REAL.TYPE (if (EQ TYPE 'REFERENCE)
                       then (LISTGET (fetch (MAILOBJ MAILOBJ.INFO) of MAILOBJ)
                                       'TYPE)
                     else TYPE))
        (CMD (MENU (create MENU
                          ITEMS _
                          `(("View as text" '\MAILOBJ.VIEW 
                                   "View the attachment as raw text, using TEdit")
                            (,(if (EQ TYPE 'REFERENCE)
                                  then                   (* ; 
                           "Note that we are storing the reference itself, not the referenced file")
                                        "Store reference"
                                else "Put to file")
                             '\MAILOBJ.PUT.FILE "Store the attachment in a file.  This operation loses information unless the file is on an NS File Server."
                             )
                            ,@[AND (EQ REAL.TYPE 'INTERPRESS)
                                   '(("Send to Printer" '\MAILOBJ.HARDCOPY 
                                            "Send the document to the printer of your choice."]
                            ,@[AND (fetch (MAILOBJ MAILOBJ.EXPANDABLE) of MAILOBJ)
                                   '(("Expand folder" '\MAILOBJ.EXPAND 
                                            "Extract the first-level subparts of the folder"]
                            ,@(SELECTQ TYPE
                                  (REFERENCE [AND (GETD 'FILEBROWSER)
                                                  (EQ (NTHCHARCODE (fetch (MAILOBJ MAILOBJ.NAME)
                                                                      of MAILOBJ)
                                                             -1)
                                                      (CHARCODE >))
                                                  `(("FileBrowse" '\MAILOBJ.FB 
                                                   "Invoke the File Browser on the referenced object"
                                                           ])
                                  NIL))
                          CENTERFLG _ T]
       (if (NULL CMD)
           then                                          (* ; 
                                                          "Nothing selected; allow TEdit to select")
                 T
         else                                            (* ; "Do the command in its own process so that the window can return to its more natural state (instead of severely clipped)")
               (ADD.PROCESS (LIST (FUNCTION \MAILOBJ.DO.COMMAND)
                                  (KWOTE CMD)
                                  (KWOTE OBJ)
                                  (KWOTE WINDOW)
                                  (KWOTE TEXTSTREAM))
                      'NAME
                      'MAILOBJ
                      'RESTARTABLE
                      'HARDRESET
                      'BEFOREEXIT
                      'DON'T)                                (* ; 
                                     "Return DON'T so that the window doesn't pop on top to select")
               'DON'T])

(\MAILOBJ.DO.COMMAND
(LAMBDA (CMD OBJ WINDOW TEXTSTREAM) (* ; "Edited  3-Jul-87 17:51 by bvm:") (RESETLST (RESETSAVE (IMAGEOBJPROP OBJ (QUOTE BUSY) T) (LIST (QUOTE IMAGEOBJPROP) OBJ (QUOTE BUSY) NIL)) (CL:FUNCALL CMD OBJ WINDOW TEXTSTREAM)))
)

(\MAILOBJ.HARDCOPY
  [LAMBDA (OBJ WINDOW)                                   (* ; "Edited 26-Jun-90 18:17 by jds")

    (* ;; "Hardcopy the attachment in MAILOBJ.  WINDOW is the window in which we are viewing it (not currently used).")

    (LET* ((*UPPER-CASE-FILE-NAMES* NIL)
           (PRINTER (GetPrinterName))
           (MAILOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM))
           (REFP (EQ (fetch (MAILOBJ MAILOBJ.TYPE) of MAILOBJ)
                     'REFERENCE))
           ATTRIBUTES PRINTRESULTS NAME DATA START)
          (if (NULL PRINTER)
              then                                       (* ; "abort")
                    NIL
            elseif (NOT (STRPOS ":" PRINTER))
              then                                       (* ; "not ns")
                    (PRINTOUT PROMPTWINDOW T PRINTER " is not an Interpress printer")
            else (SETQ PRINTER (GETNSPRINTER PRINTER))
                  (if REFP
                      then (NSPRINT PRINTER (SETQ NAME (fetch (MAILOBJ MAILOBJ.NAME)
                                                              of MAILOBJ)))
                    else                                 (* ; 
                            "Have to do this by hand, since we don't have a nice standalone stream")
                          [SETQ ATTRIBUTES
                           (\MAILOBJ.PARSE.ATTRIBUTES
                            (SETQ DATA (fetch (MAILOBJ MAILOBJ.DATA) of MAILOBJ))
                            [CONSTANT `([DOCUMENT.NAME ,@(CDR (ASSOC 'NAME \NSFILING.ATTRIBUTES]
                                        (DOCUMENT.CREATION.DATE ,@(CDR (ASSOC 'CREATED.ON 
                                                                              \NSFILING.ATTRIBUTES]
                            (SETQ START (fetch (MAILOBJ MAILOBJ.START) of MAILOBJ] 
                                                             (* ; 
                    "Parse out the name and creation date, and use them for the document name/date")
                          [if (SETQ NAME (LISTGET ATTRIBUTES 'DOCUMENT.NAME))
                              then                       (* ; "Fix up any wayward subject")
                                    (LISTPUT ATTRIBUTES 'DOCUMENT.NAME (SETQ NAME (
                                                                                \MAILOBJ.MUNGE.NAME
                                                                                   NAME]
                          [SETQ PRINTRESULTS (\NSPRINT.INTERNAL PRINTER ATTRIBUTES
                                                    (FUNCTION (LAMBDA (DATASTREAM)
                                                                (\MAILOBJ.COPY.BODY
                                                                 DATA DATASTREAM
                                                                 (+ START (fetch (MAILOBJ 
                                                                                  MAILOBJ.ATTR.LENGTH
                                                                                            )
                                                                             of MAILOBJ)))
                                                                NIL]
                          (if (AND PRINTRESULTS NSPRINT.WATCHERFLG)
                              then                       (* ; 
                  "Set up a 'watchdog' process to keep the guy informed of the print job's status.")
                                    (\NSPRINT.WATCH.JOB PRINTRESULTS PRINTER NAME)))
                  (PRINTOUT PROMPTWINDOW T NAME " sent to " (fetch NSOBJECT of (CAR PRINTER])

(\MAILOBJ.FB
  [LAMBDA (OBJ WINDOW)                                   (* ; "Edited 26-Jun-90 18:17 by jds")

    (* ;; "Invoke the File Browser on the referenced object")

    (FILEBROWSER (fetch (MAILOBJ MAILOBJ.NAME) of (IMAGEOBJPROP OBJ 'OBJECTDATUM])

(\MAILOBJ.PUT.FILE
  [LAMBDA (OBJ WINDOW)                                   (* ; "Edited 26-Jun-90 18:17 by jds")

    (* ;; "Store the attachment of MAILOBJ as file of user's choosing.  Prompt for file name.  If it's on an NS directory, we can deserialize and thus preserve the whole thing.")

    (LET*
     ((MAILOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM))
      (DATA (fetch (MAILOBJ MAILOBJ.DATA) of MAILOBJ))
      (START (fetch (MAILOBJ MAILOBJ.START) of MAILOBJ))
      (PW (CREATEW (create REGION
                          LEFT _ LASTMOUSEX
                          BOTTOM _ LASTMOUSEY
                          WIDTH _ (WINDOWPROP WINDOW 'WIDTH)
                          HEIGHT _ (HEIGHTIFWINDOW (TIMES 4 (FONTPROP DEFAULTFONT 'HEIGHT))
                                          NIL 8))
                 NIL 8))
      FILE DEVICE CONDITION)
     (if [NULL (SETQ FILE (TTYINPROMPTFORWORD "Put attachment to file: " NIL NIL PW NIL
                                     'TTY
                                     (CHARCODE (CR]
         then (PRINTOUT PW "...aborted")
       elseif (NULL (SETQ DEVICE (\GETDEVICEFROMNAME (SETQ FILE (\ADD.CONNECTED.DIR FILE))
                                            T)))
         then (PRINTOUT PW T "No such server/device")
       else
       (ALLOW.BUTTON.EVENTS)
       (PRINTOUT PW " ... ")
       (if [CL:MULTIPLE-VALUE-SETQ
                (FILE CONDITION)
                (IGNORE-ERRORS (if (EQ (fetch OPENFILE of DEVICE)
                                           (FUNCTION \NSFILING.OPENFILE))
                                   then                  (* ; 
                                                   "NS device.  Really need better test than this.")
                                         (SETFILEPTR DATA START)
                                         (LET ((*UPPER-CASE-FILE-NAMES* NIL))
                                              (DECLARE (CL:SPECIAL *UPPER-CASE-FILE-NAMES*))
                                                             (* ; "Get name pretty")
                                              (\NSFILING.DESERIALIZE FILE DATA DEVICE))
                                 else [SETQ FILE
                                           (OPENSTREAM FILE 'OUTPUT 'NEW
                                                  `((TYPE ,(fetch (MAILOBJ MAILOBJ.TYPE)
                                                              of MAILOBJ))
                                                    (SEQUENTIAL T]
                                       (PRINTOUT PW "(some attributes will be lost) ")
                                       (\MAILOBJ.COPY.BODY DATA FILE (+ START (fetch
                                                                                   (MAILOBJ 
                                                                                  MAILOBJ.ATTR.LENGTH
                                                                                          )
                                                                                     of MAILOBJ))
                                              PW)
                                       (CLOSEF FILE]
           then (PRINTOUT PW T FILE " written.")
         else (PRINTOUT PW "failed: " CONDITION])

(\MAILOBJ.VIEW
  [LAMBDA (OBJ WINDOW)                                   (* ; "Edited 26-Jun-90 18:17 by jds")

    (* ;; "View the text of the attachment.   This is often enough to tell you whether you want to bother doing something more exciting with it.")

    (RESETLST
        [LET*
         ((MAILOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM))
          (TYPE (fetch (MAILOBJ MAILOBJ.TYPE) of MAILOBJ))
          (REFP (EQ TYPE 'REFERENCE))
          (WREG (WINDOWREGION (OR (CAR (WINDOWPROP WINDOW 'EXTRAWINDOWS))
                                  WINDOW)))
          PROPS W SUBJECT START DATA DATASTART)
         [if REFP
             then (SETQ SUBJECT (fetch (MAILOBJ MAILOBJ.NAME) of MAILOBJ))
                   (SETQ TYPE (LISTGET (fetch (MAILOBJ MAILOBJ.INFO) of MAILOBJ)
                                     'TYPE))
                   (SETQ START NIL)
           else (SETQ DATA (fetch (MAILOBJ MAILOBJ.DATA) of MAILOBJ))
                 [SETQ SUBJECT (CADR (\MAILOBJ.PARSE.ATTRIBUTES DATA
                                            (CONSTANT (LIST (ASSOC 'NAME \NSFILING.ATTRIBUTES)))
                                            (SETQ DATASTART (fetch (MAILOBJ MAILOBJ.START)
                                                               of MAILOBJ]
                 (SETQ START (+ DATASTART (fetch (MAILOBJ MAILOBJ.ATTR.LENGTH) of MAILOBJ]
         [SETQ W (CREATEW (create REGION
                             using WREG LEFT _
                                   (+ (fetch (REGION LEFT) of WREG)
                                      (if (> (+ (fetch (REGION LEFT) of WREG)
                                                    (fetch (REGION WIDTH) of WREG)
                                                    MAILOBJ.WINDOWOFFSET)
                                                 SCREENWIDTH)
                                          then (- MAILOBJ.WINDOWOFFSET)
                                        else MAILOBJ.WINDOWOFFSET))
                                   BOTTOM _ (- (fetch (REGION BOTTOM) of WREG)
                                               (if (< (- (fetch (REGION BOTTOM) of WREG)
                                                             MAILOBJ.WINDOWOFFSET)
                                                          0)
                                                   then (- MAILOBJ.WINDOWOFFSET)
                                                 else MAILOBJ.WINDOWOFFSET)))
                        (CONCAT "Attachment: " (\MAILOBJ.MUNGE.NAME SUBJECT]
                                                             (* ; 
                                                  "Make window slightly overlapping display window")
         (WINDOWADDPROP WINDOW 'EXTRAWINDOWS W T)
         [if (NEQ TYPE 'TEDIT)
             then                                        (* ; 
                                  "TEdit's not so good on binary files, so just pull out the text.")
             (LET
              [(COMPACTDATA (OPENSTREAM '{NODIRCORE} 'BOTH]
              [if REFP
                  then [RESETSAVE NIL (LIST 'CLOSEF (SETQ DATA (OPENSTREAM SUBJECT 'INPUT NIL
                                                                          '((SEQUENTIAL T]
                else (SETFILEPTR DATA (+ DATASTART 4))   (* ; 
                    "Skip the version number (LONGCARDINAL).  Next comes SEQUENCE Filing.Attribute")
                      (if NIL
                          then 

                                (* ;; "First extract possible text from unknown attributes.  This is not really worth much, other than it skips the mail note, and it is completely the wrong thing on sub-mailobjs, for which none of the fields (except the subject) has been exposed.")

                                (to (\WIN DATA) bind X TYPE
                                   do (SETQ TYPE (COURIER.READ DATA NIL 'LONGCARDINAL))
                                         (if (find X in \NSMAIL.ATTRIBUTES
                                                    suchthat (EQ (CADR X)
                                                                     TYPE))
                                             then        (* ; 
                      "Something of known type--it's probably in the message header.  Just skip it")
                                                   (COURIER.SKIP.SEQUENCE DATA NIL 'UNSPECIFIED)
                                           else          (* ; 
 "Unknown attribute--extract text from it in case it's interesting.  Next word is a count of words")
                                                 (\MAILOBJ.EXTRACT.TEXT DATA COMPACTDATA
                                                        (UNFOLD (\WIN DATA)
                                                               BYTESPERWORD]
              (\MAILOBJ.EXTRACT.TEXT DATA COMPACTDATA (- (\GETEOFPTR DATA)
                                                             (GETFILEPTR DATA)))
              (SETQ DATA COMPACTDATA)
              (SETQ START NIL)
              (SETQ PROPS (LIST 'FONT LAFITEDISPLAYFONT]
         (OPENTEXTSTREAM DATA W START (AND START (GETEOFPTR DATA))
                (APPEND PROPS '(PROMPTWINDOW DON'T])])

(\MAILOBJ.MUNGE.NAME
(LAMBDA (STRING) (* ; "Edited 15-Aug-89 17:03 by bvm") (* ;; "Get rid of the CR's in string, substituting something more innocuous.") (if (OR (NULL STRING) (NOT (STRPOS "
" STRING))) then STRING else (CL:SUBSTITUTE #\\ #\Newline STRING))))

(\MAILOBJ.COPY.BODY
(LAMBDA (INSTREAM OUTSTREAM START PW) (* ; "Edited  6-Jul-87 12:47 by bvm:") (SETFILEPTR INSTREAM START) (\NSMAIL.READ.SERIALIZED.CONTENT INSTREAM OUTSTREAM) (if (NEQ (\WIN INSTREAM) 0) then (PRINTOUT (OR PW PROMPTWINDOW) T "Warning: Attachment had children, which were not processed.")))
)

(\MAILOBJ.EXPAND
  [LAMBDA (OBJ WINDOW TEXTSTREAM)                        (* ; "Edited 26-Jun-90 18:17 by jds")
    (LET* ((MAILOBJ (IMAGEOBJPROP OBJ 'OBJECTDATUM))
           (DATA (fetch (MAILOBJ MAILOBJ.DATA) of MAILOBJ))
           (IMAGEPOS (TEDIT.FIND.OBJECT TEXTSTREAM OBJ))
           NUMCHILDREN CHILDREN SUBDATA SUBSTART TYPE PARSE)
          (SETFILEPTR DATA (+ (fetch (MAILOBJ MAILOBJ.START) of MAILOBJ)
                              (fetch (MAILOBJ MAILOBJ.ATTR.LENGTH) of MAILOBJ)))
          (\NSMAIL.DISCARD.SERIALIZED.CONTENT DATA)      (* ; 
                                     "Skip over the body of the folder (should be empty, actually)")
          (if (EQ (SETQ NUMCHILDREN (\WIN DATA))
                      0)
              then                                       (* ; 
                                                           "Why did it say it was a directory?")
                    (PRINTOUT PROMPTWINDOW T "There is nothing in that 'folder' to expand!")
            else (to NUMCHILDREN do              (* ; 
                                                           "copy each child into its own image obj")
                                               (SETQ SUBDATA (OPENSTREAM '{NODIRCORE} 'BOTH))
                                               (COURIER.WRITE SUBDATA \SERIALIZED.FILE.VERSION NIL
                                                      'LONGCARDINAL)
                                               (SETQ SUBSTART (\MAILOBJ.COPY.CHILD DATA SUBDATA))
                                                             (* ; "Copy recursive part")
                                               (SETQ PARSE (\MAILOBJ.PARSE.ATTRIBUTES
                                                            SUBDATA
                                                            (CONSTANT (LIST (ASSOC 'FILE.TYPE 
                                                                                 \NSFILING.ATTRIBUTES
                                                                                   )
                                                                            (ASSOC 'NAME 
                                                                                 \NSFILING.ATTRIBUTES
                                                                                   )))
                                                            0))
                                               (SETQ TYPE (LISTGET PARSE 'FILE.TYPE))
                                               [push CHILDREN (\MAILOBJ.CREATE
                                                                   SUBDATA
                                                                   (AND TYPE (\TYPE.FROM.FILETYPE
                                                                              TYPE))
                                                                   SUBSTART
                                                                   (LISTGET PARSE 'NAME] 
                                                             (* ; 
                                        "Create object, parsing the type field out of the raw data")
                            )
                  (add IMAGEPOS 1)
                  (TEXTPROP TEXTSTREAM 'READONLY (PROG1 (TEXTPROP TEXTSTREAM 'READONLY)
                                                     (TEXTPROP TEXTSTREAM 'READONLY NIL)
                                                             (* ; 
                                "This ought to be one call, but the macro does not expand properly")
                                                     (for C in CHILDREN
                                                        do 
                                                             (* ; 
"Insert the objects following obj in reverse order of creation, so they come out right in the end.")
                                                              (TEDIT.INSERT.OBJECT C TEXTSTREAM 
                                                                     IMAGEPOS)))])

(\MAILOBJ.COPY.CHILD
(LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited  6-Jul-87 14:41 by bvm:") (* ;; "This is the counterpart to \nsmail.read.serialized.tree, except that it copies the data as it parses it, rather than interpreting it.  Returns file pointer of the start of the main child's data section.") (* ;; "We are parsing here the recursive part of Filing.SerializedFile: SerializedTree, which consists of: Sequence of Attribute;  Content;  children = Sequence of SerializedTree") (LET (ATTRLENGTH SUBSTART NCHILDREN LASTSEGMENT?) (\WOUT OUTSTREAM (SETQ ATTRLENGTH (\WIN INSTREAM))) (* ; "number of attributes") (to ATTRLENGTH do (RPTQ 4 (\BOUT OUTSTREAM (\BIN INSTREAM))) (* ; "Copy attribute type (longcardinal)") (\MAILOBJ.COPY.SEQUENCE INSTREAM OUTSTREAM) (* ; "Copy attribute value (sequence unspecified)")) (SETQ SUBSTART (GETFILEPTR OUTSTREAM)) (* ;; "Now copy the body, which is StreamOfUnspecified followed by lastByteIsSignficant boolean") (do (\WOUT OUTSTREAM (SETQ LASTSEGMENT? (\WIN INSTREAM))) (* ; "1 => this is last segment") (\MAILOBJ.COPY.SEQUENCE INSTREAM OUTSTREAM) (* ; "Copy the sequence") repeatuntil (NEQ LASTSEGMENT? 0) finally (\WOUT OUTSTREAM (\WIN INSTREAM)) (* ; "Copy lastByteIsSignficant boolean")) (\WOUT OUTSTREAM (SETQ NCHILDREN (\WIN INSTREAM))) (to NCHILDREN do (\MAILOBJ.COPY.CHILD INSTREAM OUTSTREAM)) SUBSTART))
)

(\MAILOBJ.COPY.SEQUENCE
(LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited  6-Jul-87 14:37 by bvm:") (* ;; "Copy a Sequence of Unspecified from in to out.") (LET ((SEQLENGTH (\WIN INSTREAM))) (\WOUT OUTSTREAM SEQLENGTH) (* ; "Representation is sequence length (word) followed by that many words") (RPTQ (UNFOLD SEQLENGTH BYTESPERWORD) (\BOUT OUTSTREAM (\BIN INSTREAM)))))
)

(\MAILOBJ.EXTRACT.TEXT
(LAMBDA (DATA OUTSTREAM LEN) (* ; "Edited 15-Aug-89 16:38 by bvm") (* ;; "Copy LEN bytes from the stream DATA to OUTSTREAM, where all the runs of non-printing characters are replaced by some small number of ugly characters that won't upset tedit.") (to LEN bind CH HELDCH (SKIPPING _ -1) do (if (OR (>= (SETQ CH (\BIN DATA)) 127) (AND (< CH (CHARCODE SPACE)) (SELCHARQ CH ((TAB CR) NIL) ( (* ; "VP eol") (SETQ CH (CHARCODE CR)) NIL) T))) then (* ; "Junk") (SETQ HELDCH NIL) (* ; "I don't care if the previous byte was accidentally ascii") (if (EVENP (add SKIPPING 1) 16) then (BOUT OUTSTREAM MAILOBJ.SKIPCHAR)) elseif (< SKIPPING 0) then (* ; "in a nice ascii section") (BOUT OUTSTREAM CH) elseif HELDCH then (* ; "We were just waiting to see...") (BOUT OUTSTREAM HELDCH) (SETQ HELDCH NIL) (SETQ SKIPPING -1) (BOUT OUTSTREAM CH) else (* ; "We had been skipping.  Don't print this byte until we see the next byte is nice, too, so as to reduce the gibberish of accidental ascii in the middle of binary") (SETQ HELDCH CH))) OUTSTREAM)
)

(\MAILOBJ.PARSE.ATTRIBUTES
(LAMBDA (DATA FIELDS START) (* ; "Edited 14-Feb-90 16:26 by bvm") (* ;; "Parse the SUBJECT field out of the serialized stream DATA beginning at START.  FIELDS is in the format of \nsfiling.attributes entries") (SETFILEPTR DATA (+ START 4)) (* ; "Skip the version number (LONGCARDINAL).  Next comes SEQUENCE Filing.Attribute") (to (\WIN DATA) bind (CNT _ (LENGTH FIELDS)) X TYPE do (SETQ TYPE (COURIER.READ DATA NIL (QUOTE LONGCARDINAL))) (if (find old X in FIELDS suchthat (EQ (CADR X) TYPE)) then (* ; "X = (type number interpretation)") (\WIN DATA) (push $$VAL (CAR X) (COURIER.READ DATA NIL (CADDR X))) (if (<= (SETQ CNT (SUB1 CNT)) 0) then (* ;; "Found them all") (RETURN $$VAL)) else (COURIER.SKIP.SEQUENCE DATA NIL (QUOTE UNSPECIFIED)))))
)
)

(ADDTOVAR FILING.TYPES (VIEWPOINT 4353)
                           (RES 4428)
                           (XEROX860 5120)
                           (REFERENCE 4427)
                           (MAILFOLDER 4417))

(RPAQQ MAILOBJ.REFERENCE.FIELD
       (REFERENCE 4421 (NAMEDRECORD (FILE.ID (FILING . FILE.ID))
                              (SERVICE NSNAME)
                              (ADDRESS NSADDRESS)
                              (HOST STRING)
                              (DIRECTORY STRING)
                              (NAME STRING)
                              (TYPE (FILING . ATTRIBUTE.TYPE))
                              (NIL UNSPECIFIED)
                              (PAGES CARDINAL)
                              (VERSION CARDINAL)
                              (FLAGS CARDINAL))))

(RPAQ? MAILOBJ.WINDOWOFFSET 16)

(RPAQ? MAILOBJ.SKIPCHAR (CHARCODE "."))
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD MAILOBJ (MAILOBJ.IMAGE MAILOBJ.BOX MAILOBJ.TYPE MAILOBJ.DATA MAILOBJ.ATTR.LENGTH 
                           MAILOBJ.START MAILOBJ.NAME MAILOBJ.EXPANDABLE . MAILOBJ.INFO))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \MAILOBJ.REFERENCE.LAST.FILED 8192)


(CONSTANTS \MAILOBJ.REFERENCE.LAST.FILED)
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\MAILOBJ.INIT)

(AND (EQ MAKESYSNAME :LYRIC)
     (FILESLOAD (SYSLOAD)
            NSRANDOM))
)



(* ; "sending mail")

(DEFINEQ

(\NSMAIL.SEND.PARSE
(LAMBDA (MSG EDITORWINDOW) (* ; "Edited 17-Jan-89 15:55 by bvm") (PROG ((SENDER (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*)) RECIPIENTS MSGFIELDS FORMATTEDP HEADEREOF INTERESTINGFIELDS SUBJECT ATTACHMENT) (OR (SETQ MSGFIELDS (\LAFITE.PREPARE.SEND MSG EDITORWINDOW \LAPARSE.NSMAIL)) (RETURN)) (COND ((EQ (CAAR MSGFIELDS) (QUOTE EOF)) (SETQ HEADEREOF (CADR (pop MSGFIELDS))))) (for PAIR in MSGFIELDS do (SELECTQ (CAR PAIR) ((To cc From Reply-to) (push INTERESTINGFIELDS (RPLACD PAIR (\NSMAIL.PARSE (CDR PAIR) SENDER EDITORWINDOW))) (SELECTQ (CAR PAIR) ((To cc) (LET ((EXPANDED (for NAME in (CDR PAIR) join (if (CL:STRING= (fetch NSDOMAIN of NAME) ";") then (* ; "DL syntax") (\NSMAIL.EXPAND.DL (fetch NSOBJECT of NAME) SENDER EDITORWINDOW) else (LIST NAME))))) (SETQ RECIPIENTS (COND (RECIPIENTS (NS.REMOVEDUPLICATES (APPEND EXPANDED RECIPIENTS))) (T EXPANDED))))) (PROGN (* ; "Might want to check validity of From and Reply-to") NIL))) ((Subject In-Reply-to) (RPLACD PAIR (COND ((CDDR PAIR) (CONCATLIST (CDR PAIR))) (T (CADR PAIR)))) (* ; "Make one string") (push INTERESTINGFIELDS PAIR) (COND ((EQ (CAR PAIR) (QUOTE Subject)) (SETQ SUBJECT (CDR PAIR))))) (Date (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Date not allowed")) (Sender (\SENDMESSAGEFAIL EDITORWINDOW "User-supplied Sender not allowed")) (Format (SETQ FORMATTEDP (SELECTQ (CADR PAIR) (TEDIT T) NIL))) ((REFERENCE ATTACHMENT) (if ATTACHMENT then (\SENDMESSAGEFAIL EDITORWINDOW "Can only send a single attachment")) (SETQ ATTACHMENT T) (push INTERESTINGFIELDS PAIR)) NIL)) (COND ((NULL RECIPIENTS) (\SENDMESSAGEFAIL EDITORWINDOW "No recipients!"))) (OR FORMATTEDP (SELECTQ (\LAFITE.CHOOSE.MSG.FORMAT MSG NIL EDITORWINDOW) (TEDIT (SETQ FORMATTEDP T)) (NIL (* ; "Aborted") (RETURN)) NIL)) (RETURN (create NSMAILPARSE NSPSUBJECT _ SUBJECT NSPRECIPIENTS _ RECIPIENTS NSPSTART _ HEADEREOF NSPFIELDS _ INTERESTINGFIELDS NSPFORMATTED _ FORMATTEDP))))
)

(\NSMAIL.PARSE.REFERENCE
(LAMBDA (FILENAME EDITWINDOW) (* ; "Edited 17-Jan-89 15:55 by bvm") (LET* ((*UPPER-CASE-FILE-NAMES* NIL) (FULLNAME (FINDFILE FILENAME T))) (COND ((NULL FULLNAME) (\SENDMESSAGEFAIL EDITWINDOW "Can't find reference file " FILENAME)) (T (LET* ((FIELDS (UNPACKFILENAME.STRING FULLNAME)) (HOST (LISTGET FIELDS (QUOTE HOST))) (NSHOST (PARSE.NSNAME HOST)) (ADDRESS (LOOKUP.NS.SERVER NSHOST)) (NAME (LISTGET FIELDS (QUOTE NAME))) (EXT (LISTGET FIELDS (QUOTE EXTENSION))) (VERSION (LISTGET FIELDS (QUOTE VERSION))) (ID (GETFILEINFO FULLNAME (QUOTE FILE.ID))) (TYPE (GETFILEINFO FULLNAME (QUOTE FILE.TYPE))) (SIZE (GETFILEINFO FULLNAME (QUOTE SIZE)))) (COND ((NOT (AND (STRPOS ":" HOST) ADDRESS)) (\SENDMESSAGEFAIL EDITWINDOW "Reference file must be on NS server")) ((NOT (AND ID TYPE SIZE)) (\SENDMESSAGEFAIL EDITWINDOW "Can't lookup info on " FULLNAME)) (T (BQUOTE ((FILE.ID (\, ID)) (SERVICE (\, NSHOST)) (ADDRESS (\, ADDRESS)) (HOST (\, HOST)) (DIRECTORY (\, (CL:SUBSTITUTE #\/ #\> (UNPACKFILENAME.STRING FULLNAME (QUOTE DIRECTORY))))) (NAME (\, (if EXT then (SETQ NAME (CONCAT NAME "." EXT)) else NAME))) (TYPE (\, (if (OR (NEQ TYPE 0) (NULL EXT)) then (* ; "Interesting type, or no clue from extension") TYPE elseif (AND (SETQ TYPE (\NSMAIL.GUESS.FILE.TYPE NAME EXT)) (SELECTQ (\SENDMESSAGE.MENUPROMPT EDITWINDOW (\LAFITE.CREATE.MENU (BQUOTE (((\, (CONCAT "Change file type to " TYPE)) T) ("Leave as type BINARY" NIL) ("Abort" (QUOTE ABORT)))) "Fix type of reference file?") "Referenced document is of type BINARY; some mail clients will not understand.") (NIL NIL) (ABORT (ERROR!)) (if (SETFILEINFO FULLNAME (QUOTE TYPE) (SETQ TYPE (\FILETYPE.FROM.TYPE TYPE))) then TYPE else (\SENDMESSAGEFAIL EDITWINDOW "Could not set the file type")))) else (* ; "Oh, give up, leave it binary") 0))) (NIL 0) (PAGES (\, (ADD1 SIZE))) (VERSION (\, (OR (AND VERSION (MKATOM VERSION)) 0))) (FLAGS 0))))))))))
)

(\NSMAIL.EXPAND.DL
(LAMBDA (DL SENDER EDITWINDOW) (* ; "Edited 16-Jan-89 14:04 by bvm") (LET ((FILENAME (PACKFILENAME.STRING (QUOTE BODY) (if (EQL (CL:CHAR DL 0) #\") then (* ; "quoted file name, take off the quotes first") (CL:SUBSEQ DL 1 (- (CL:LENGTH DL) 1)) else DL) (QUOTE EXTENSION) LAFITEDL.EXT)) STREAM) (if (NULL (SETQ FILENAME (if (OR (UNPACKFILENAME.STRING FILENAME (QUOTE HOST)) (UNPACKFILENAME.STRING FILENAME (QUOTE DIRECTORY))) then (INFILEP FILENAME) else (* ; "Search default directories") (FINDFILE FILENAME T (CONS LAFITEDEFAULTHOST&DIR LAFITEDLDIRECTORIES))))) then (\SENDMESSAGEFAIL EDITWINDOW "Can't find file named " DL) elseif (NULL (SETQ STREAM (CAR (NLSETQ (OPENTEXTSTREAM (MKATOM FILENAME)))))) then (\SENDMESSAGEFAIL EDITWINDOW "Can't open " DL) else (RESETLST (RESETSAVE NIL (LIST (QUOTE CLOSEF) STREAM)) (* ; "I hope this closes the file.  We used OPENTEXTSTREAM instead of OPEN so that file can contain tedit formatting.") (bind LINE while (SETQ LINE (CL:READ-LINE STREAM NIL NIL)) join (\NSMAIL.PARSE LINE SENDER EDITWINDOW))))))
)

(\NSMAIL.PARSE
(LAMBDA (FIELD DEFAULTDOMAIN EDITWINDOW) (* bvm%: " 3-Jul-84 16:21") (NS.REMOVEDUPLICATES (COND ((LISTP FIELD) (for PIECE in FIELD join (\NSMAIL.PARSE1 PIECE DEFAULTDOMAIN EDITWINDOW))) (T (\NSMAIL.PARSE1 FIELD DEFAULTDOMAIN EDITWINDOW)))))
)

(\NSMAIL.PARSE1
(LAMBDA (FIELD DEFAULTDOMAIN EDITWINDOW) (* bvm%: " 3-Jul-84 16:26") (COND (FIELD (bind ADDR (START _ 1) COMMA when (PROGN (SETQ ADDR (SUBSTRING FIELD START (COND ((SETQ COMMA (STRPOS (QUOTE %,) FIELD START)) (SUB1 COMMA))))) (do (* ; "Strip leading blanks") (SELCHARQ (CHCON1 ADDR) ((SPACE TAB) (GNC ADDR)) (RETURN))) (do (* ; "Strip trailing blanks") (SELCHARQ (NTHCHARCODE ADDR -1) ((SPACE TAB) (GLC ADDR)) (RETURN))) (NEQ (NCHARS ADDR) 0)) collect (PARSE.NSNAME ADDR NIL DEFAULTDOMAIN) repeatwhile (COND (COMMA (SETQ START (ADD1 COMMA))))))))
)

(NS.REMOVEDUPLICATES
(LAMBDA (LST) (* ; "Edited  6-Jun-88 13:38 by bvm") (CL:REMOVE-DUPLICATES LST :TEST (FUNCTION EQUAL.CH.NAMES)))
)

(\NSMAIL.SEND
  [LAMBDA (MSG PARSE EDITORWINDOW ABORTWINDOW)           (* ; "Edited 26-Jun-90 18:25 by jds")

(* ;;; "MSG is the entire text of the message -- RECIPIENTS is a parsed list of recipients")

    (DECLARE (SPECVARS MSG START MSGFIELDS EDITORWINDOW ABORTWINDOW FORMATSTREAM REFERENCE 
                        ATTACHMENT ATTACHED-ATTRIBUTES BODYTYPE BODYLENGTH NOTEP))
                                                             (* ; 
                                                           "For \NSMAIL.SEND.MESSAGE.CONTENT")
    (RESETLST
        (PROG ((PWINDOW (AND EDITORWINDOW (GETPROMPTWINDOW EDITORWINDOW)))
               (RECIPIENTS (fetch (NSMAILPARSE NSPRECIPIENTS) of PARSE))
               (START (OR (fetch (NSMAILPARSE NSPSTART) of PARSE)
                          (GETEOFPTR MSG)))
               (MSGFIELDS (fetch (NSMAILPARSE NSPFIELDS) of PARSE))
               (CREDENTIALS (fetch (LAFITEMODEDATA CREDENTIALS) of *LAFITE-MODE-DATA*))
               FORMATSTREAM REFERENCE ATTACHMENT BODYTYPE BODYLENGTH NOTEP COURIERSTREAM DATASTREAM 
               RECIPIENTSCHECK SENDRESULT SENDERFIELD DATEFIELD TYPE MAILDROP RESULTS 
               ATTACHED-ATTRIBUTES)
              [COND
                 (PWINDOW                                    (* ; 
      "Make sure prompt window will expand as needed.  Probably generic sendmessage should do this")
                        (RESETSAVE (TTYDISPLAYSTREAM PWINDOW))
                        (RESETSAVE (LINELENGTH T]
              (COND
                 ((AND (fetch (NSMAILPARSE NSPFORMATTED) of PARSE)
                       (TEDIT.FORMATTEDFILEP MSG))           (* ; 
                "Message is formatted, so get info.  Have to exclude header, since it is not sent.")
                  (SETQ MSG (COPYTEXTSTREAM MSG))
                  (TEDIT.DELETE MSG 1 START)
                  (SETQ FORMATSTREAM (COERCETEXTOBJ MSG 'SPLIT))
                                                             (* ; "Get (body  . formatting)")
                  (SETQ MSG (OPENSTREAM (CAR FORMATSTREAM)
                                   'INPUT))
                  (SETQ FORMATSTREAM (OPENSTREAM (CDR FORMATSTREAM)
                                            'INPUT))
                  (SETQ START 0))
                 ((AND (TEXTSTREAMP MSG)
                       (TEDIT.FORMATTEDFILEP MSG))           (* ; "Message has formatting, but caller asked to send it as plain text.  Carefully coerce it, since TEDIT ns chars and image objects don't pass thru COPYBYTES very well")
                  (SETQ MSG (LAFITE.MAKE.PLAIN.TEXTSTREAM MSG START))
                  (SETQ START 0)))
              (SETQ BODYLENGTH (- (GETEOFPTR MSG)
                                  START))
              (SETQ REFERENCE (ASSOC 'REFERENCE MSGFIELDS))
              (SETQ ATTACHMENT (ASSOC 'ATTACHMENT MSGFIELDS))
              (if (OR REFERENCE ATTACHMENT)
                  then                                   (* ; "Text must be sent as mail note")
                        (if (< BODYLENGTH *NSMAIL-MAX-NOTE-LENGTH*)
                            then (SETQ NOTEP T)
                          else (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW 
                                                  "Message text too long to send with attachment")))
                        (if (AND REFERENCE ATTACHMENT)
                            then (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW 
                                                    "Can't send both attachment file AND reference"))
                               )
                elseif (AND *NSMAIL-SEND-MAIL-NOTES* (< BODYLENGTH *NSMAIL-MAX-NOTE-LENGTH*))
                  then (SETQ NOTEP T))
              (if ATTACHMENT
                  then (SETQ MSGFIELDS (DREMOVE ATTACHMENT MSGFIELDS))
                        (SETQ ATTACHMENT (\NSMAIL.PREPARE.ATTACHMENT (CADR ATTACHMENT)))
                elseif REFERENCE
                  then (RPLACD REFERENCE (\NSMAIL.PARSE.REFERENCE (CADR REFERENCE)
                                                    EDITORWINDOW))
                        (SETQ BODYTYPE \NSMAIL.REFERENCE.BODYTYPE))
              [COND
                 (PWINDOW (CLEARW PWINDOW)
                        (LET ((TYPE (if REFERENCE
                                        then (CADR (ASSOC 'TYPE (CDR REFERENCE)))
                                      else BODYTYPE)))
                             (CL:FORMAT PWINDOW 
                                "Delivering ~:[~;formatted ~]~@[with ~A ~]~@[~A ~]to ~D recipient~:P"
                                    FORMATSTREAM [AND TYPE (CL:STRING-CAPITALIZE (MKSTRING
                                                                                  (
                                                                                  \TYPE.FROM.FILETYPE
                                                                                   TYPE]
                                    (COND
                                       (REFERENCE "reference")
                                       (ATTACHMENT "attachment"))
                                    (LENGTH RECIPIENTS]
              [COND
                 ((NULL (SETQ MAILDROP (\NSMAIL.FINDSERVER)))
                  (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't find a mail drop"]
              (to 3 until (SETQ COURIERSTREAM (COURIER.OPEN MAILDROP NIL T 'NSMAILER))
                 do                                      (* ; 
                                                           "loop 3 times trying to start this send")
                       (DISMISS 1000))
              [COND
                 ((NULL COURIERSTREAM)
                  (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW "Couldn't connect to a maildrop"]
              (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
                                   COURIERSTREAM))
              (AND PWINDOW (printout PWINDOW '|...|))
              (SETQ RESULTS (COURIER.CALL COURIERSTREAM 'MAILTRANSPORT 'POST (CAR CREDENTIALS)
                                   (CDR CREDENTIALS)
                                   RECIPIENTS NIL T \NSMAIL.CTSTANDARD.MESSAGE NIL
                                   (FUNCTION \NSMAIL.SEND.MESSAGE.CONTENT)
                                   'RETURNERRORS))
              [COND
                 ((EQ (CAR (LISTP RESULTS))
                      'ERROR)
                  (RETURN (\LAFITE.SEND.FAIL EDITORWINDOW (SELECTQ (CADR RESULTS)
                                                              (INVALID.RECIPIENTS 
                                                                   (\LAFITE.INVALID.RECIPIENTS
                                                                    (CDDR RESULTS)))
                                                              (MKSTRING (CDR RESULTS]
              (AND NSMAILDEBUGFLG (printout PROMPTWINDOW T "Post results: " RESULTS))
              (RETURN (LENGTH RECIPIENTS))))])

(\NSMAIL.PREPARE.ATTACHMENT
(LAMBDA (FILE) (* ; "Edited 14-Sep-89 12:15 by bvm") (DECLARE (USEDFREE MSGFIELDS EDITORWINDOW ATTACHMENT ATTACHED-ATTRIBUTES BODYTYPE BODYLENGTH)) (LET* ((HOST (UNPACKFILENAME.STRING FILE (QUOTE HOST))) (SERIALIZED (STRPOS ":" HOST)) (ATTRCOUNT 0) ATTRSTREAM) (CL:MULTIPLE-VALUE-BIND (STREAM CONDITION) (IGNORE-ERRORS (if SERIALIZED then (\NSFILING.GETFILE (\GETDEVICEFROMHOSTNAME (MKATOM (U-CASE HOST))) FILE (QUOTE SERIALIZE) (QUOTE OLD) NIL NIL T) else (OPENSTREAM FILE (QUOTE INPUT)))) (if (NULL STREAM) then (\LAFITE.SEND.FAIL EDITORWINDOW (OR CONDITION "Attachment not found.")) (ERROR!)) (RESETSAVE NIL (LIST (FUNCTION CLOSEF) STREAM)) (if SERIALIZED then (* ; "Parse out the attributes portion of the serialized file and save those that are not specifically mail attributes") (SETQ ATTRSTREAM (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (\NSMAIL.CHECK.SERIALIZED.VERSION STREAM) (to (\WIN STREAM) bind TYPE WORDCOUNT do (SETQ TYPE (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) (if (EQ TYPE (\NSMAIL.ATTRIBUTE.TYPE BodyType)) then (* ; "We always send type explicitly") (\WIN STREAM) (SETQ BODYTYPE (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) elseif (OR (for TRIPLE in \NSMAIL.ATTRIBUTES thereis (EQ TYPE (CADR TRIPLE))) (AND (< TYPE 100) (for TRIPLE in \NSFILING.ATTRIBUTES when (EQ TYPE (CADR TRIPLE)) do (* ; "Only a few filing attributes are interesting.  Is.directory appears to be vital (the server won't deserialize something with children without it)") (RETURN (NOT (FMEMB (CAR TRIPLE) (QUOTE (IS.DIRECTORY CREATED.BY CREATED.ON MODIFIED.BY MODIFIED.ON)))))))) then (* ; "A mail attribute or file-specific file attribute, skip it") (COURIER.SKIP.SEQUENCE STREAM NIL (QUOTE UNSPECIFIED)) else (* ; "Save it") (add ATTRCOUNT 1) (COURIER.WRITE ATTRSTREAM TYPE NIL (QUOTE LONGCARDINAL)) (\WOUT ATTRSTREAM (SETQ WORDCOUNT (\WIN STREAM))) (COPYBYTES STREAM ATTRSTREAM (UNFOLD WORDCOUNT BYTESPERWORD)))) (SETQ ATTACHED-ATTRIBUTES (CONS ATTRCOUNT ATTRSTREAM)) else (* ; "Not on an NS server, let's investigate the type") (CASE (SETQ BODYTYPE (\FILETYPE.FROM.TYPE (GETFILEINFO STREAM (QUOTE TYPE)))) ((NIL 0) (* ; "Under specified") (if (SETQ BODYTYPE (\NSMAIL.GUESS.FILE.TYPE (FULLNAME STREAM))) then (SETQ BODYTYPE (\FILETYPE.FROM.TYPE BODYTYPE)) elseif (\SENDMESSAGE.MENUPROMPT EDITORWINDOW (\LAFITE.CREATE.MENU (QUOTE (("Send as BINARY attachment" T) ("Abort" NIL))) "Send attachment?") "Warning: Type of attached file is unknown; most mail clients can't do anything interesting with this.") then (SETQ BODYTYPE 0) else (ERROR!)))) (push MSGFIELDS (BQUOTE (MODIFIED.ON (\,@ (GETFILEINFO STREAM (QUOTE ICREATIONDATE))))))) STREAM)))
)

(\NSMAIL.GUESS.FILE.TYPE
(LAMBDA (FILENAME EXT) (* ; "Edited 17-Jan-89 15:42 by bvm") (* ;; "Given a file name, try to guess what type it is from the extension, since file's TYPE property was boring.  EXT is computed from FILENAME if omitted.") (OR (CAR (CL:ASSOC (OR EXT (UNPACKFILENAME.STRING FILENAME (QUOTE EXTENSION))) FILING.TYPES :TEST (QUOTE STRING-EQUAL))) (LET ((TYPE (PRINTFILETYPE.FROM.EXTENSION FILENAME))) (AND TYPE (CAR (CL:ASSOC TYPE FILING.TYPES :TEST (QUOTE STRING-EQUAL)))))))
)

(\NSMAIL.SEND.MESSAGE.CONTENT
(LAMBDA (DATASTREAM) (* ; "Edited 13-Sep-89 17:15 by bvm") (DECLARE (USEDFREE MSG START MSGFIELDS EDITORWINDOW ABORTWINDOW FORMATSTREAM REFERENCE ATTACHMENT ATTACHED-ATTRIBUTES BODYTYPE BODYLENGTH NOTEP)) (* ; "From \NSMAIL.SEND") (* ;; "Transmits the bulkdata portion of the message") (PROG ((SENDER (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) (* ;; "Want to send a serialized file on DATASTREAM --- version plus SerializedTree.  See \NSMAIL.READ.SERIALIZED.TREE") (COURIER.WRITE DATASTREAM \SERIALIZED.FILE.VERSION NIL (QUOTE LONGCARDINAL)) (* ; "Version") (* ;; "Now comes (SEQUENCE ATTRIBUTE);  the attributes we want to send are those in MSGFIELDS plus Date, From, BodyType and Note") (\WOUT DATASTREAM (+ (LENGTH MSGFIELDS) (if FORMATSTREAM then (* ; "Also a LispFormatting item") 1 else 0) (if NOTEP then (* ; "Send body as Note attribute") (SETQ BODYLENGTH 0) 1 else (* ; "Send as body") 0) (if ATTACHED-ATTRIBUTES then (* ; "From serialized file") (CAR ATTACHED-ATTRIBUTES) else 0) 4)) (* ; "Number of attributes") (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE Date) (IDATE)) (COND ((ASSOC (QUOTE From) MSGFIELDS) (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE Sender) SENDER)) (T (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE From) (LIST SENDER)))) (for PAIR in MSGFIELDS do (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (CAR PAIR) (CDR PAIR))) (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE BodyType) (COND (BODYTYPE) (NOTEP \NSMAIL.EMPTY.BODYTYPE) (T \NSMAIL.TEXT.BODYTYPE))) (\NSMAIL.WRITE.ATTRIBUTE DATASTREAM (QUOTE BodySize) (if ATTACHMENT then (SETQ BODYLENGTH (GETEOFPTR ATTACHMENT)) else BODYLENGTH)) (COND ((AND ABORTWINDOW (WINDOWPROP ABORTWINDOW (QUOTE ABORT))) (ERROR!))) (COND (NOTEP (\NSMAIL.SEND.STREAM.AS.STRING MSG DATASTREAM START (\NSMAIL.ATTRIBUTE.TYPE Note)))) (COND (FORMATSTREAM (\NSMAIL.SEND.STREAM.AS.STRING FORMATSTREAM DATASTREAM 0 (\NSMAIL.ATTRIBUTE.TYPE LispFormatting)))) (PROGN (* ; "Now the content of the serialized tree, first part of which is a Bulkdata.StreamOfUnspecified") (COND (ATTACHMENT (if ATTACHED-ATTRIBUTES then (* ; "We have a serialized file here already.  First send the rest of the interesting attributes") (COPYBYTES (CDR ATTACHED-ATTRIBUTES) DATASTREAM 0 -1) (* ; "Then the rest of the serialization") (COPYBYTES ATTACHMENT DATASTREAM) else (COURIER.WRITE.STREAM.UNSPECIFIED DATASTREAM ATTACHMENT 0 BODYLENGTH))) (NOTEP (* ; "Null content") (\WOUT DATASTREAM 1) (* ; "Last segment") (\WOUT DATASTREAM 0) (* ; "Empty sequence")) (T (COURIER.WRITE.STREAM.UNSPECIFIED DATASTREAM MSG START (GETEOFPTR MSG))))) (if (NOT ATTACHED-ATTRIBUTES) then (* ; "Finally, the last of the serialized tree") (\WOUT DATASTREAM (LOGXOR (LOGAND BODYLENGTH 1) 1)) (* ; "Last byte significant (even number of bytes)") (\WOUT DATASTREAM 0) (* ; "No children")) (COND ((NULL ABORTWINDOW)) ((WINDOWPROP ABORTWINDOW (QUOTE ABORT)) (ERROR!)) (T (* ; "Too late to abort now") (DELETEMENU (CAR (WINDOWPROP ABORTWINDOW (QUOTE MENU))) NIL ABORTWINDOW))) (RETURN NIL)))
)

(COURIER.WRITE.STREAM.UNSPECIFIED
(LAMBDA (OUTSTREAM INSTREAM START END) (* bvm%: "16-May-85 14:24") (* ;;; "Copies INSTREAM from START to END onto OUTSTREAM in the form of Bulkdata.StreamOfUnspecified --- format is one or more concatenations of {lastSegmentP,SequenceUnspecified} --- returns T if even number of bytes written, NIL if odd") (LET (LENGTH) (COND (END (SETFILEPTR INSTREAM START) (SETQ LENGTH (IDIFFERENCE (COND ((EQ END -1) (GETEOFPTR INSTREAM)) (T END)) START))) (START (SETQ LENGTH START)) (T (SETQ LENGTH (IDIFFERENCE (GETEOFPTR INSTREAM) (GETFILEPTR INSTREAM))))) (while (GREATERP LENGTH MAX.BULK.SEGMENT.LENGTH) do (\WOUT OUTSTREAM 0) (* ; "Not last segment") (\WOUT OUTSTREAM (FOLDHI MAX.BULK.SEGMENT.LENGTH BYTESPERWORD)) (* ; "Word length of this segment") (COPYBYTES INSTREAM OUTSTREAM MAX.BULK.SEGMENT.LENGTH) (SETQ LENGTH (IDIFFERENCE LENGTH MAX.BULK.SEGMENT.LENGTH))) (\WOUT OUTSTREAM 1) (* ; "Last segment") (\WOUT OUTSTREAM (FOLDHI LENGTH BYTESPERWORD)) (* ; "Word length of this segment") (COPYBYTES INSTREAM OUTSTREAM LENGTH) (COND ((EVENP LENGTH) T) (T (* ; "Garbage last byte") (\BOUT OUTSTREAM 0) NIL))))
)

(\NSMAIL.SEND.STREAM.AS.STRING
(LAMBDA (INSTREAM OUTSTREAM START ATTRIBUTE) (* bvm%: "30-Jul-84 15:31") (* ;; "Writes the contents of INSTREAM, beginning at byte START, to OUTSTREAM in the form of a Filing Attribute whose type is ATTRIBUTE and whose value is a string") (PROG ((EOF (GETEOFPTR INSTREAM)) LENGTH) (COURIER.WRITE OUTSTREAM ATTRIBUTE NIL (QUOTE LONGCARDINAL)) (\WOUT OUTSTREAM (ADD1 (FOLDHI (SETQ LENGTH (IDIFFERENCE EOF START)) BYTESPERWORD))) (* ; "Sequence length") (\WOUT OUTSTREAM LENGTH) (* ; "String length") (COPYBYTES INSTREAM OUTSTREAM START EOF) (COND ((ODDP LENGTH) (\BOUT OUTSTREAM 0)))))
)

(\NSMAIL.WRITE.ATTRIBUTE
(LAMBDA (STREAM TYPE VALUE) (* ; "Edited 17-Jan-89 16:39 by bvm") (LET* (FILINGP (TYPEINFO (if (EQ TYPE (QUOTE REFERENCE)) then (* ; "This is handled specially so that we don't read references on input") MAILOBJ.REFERENCE.FIELD else (OR (ASSOC TYPE \NSMAIL.ATTRIBUTES) (SETQ FILINGP (ASSOC TYPE \NSFILING.ATTRIBUTES)))))) (if TYPEINFO then (COURIER.WRITE STREAM (CADR TYPEINFO) NIL (QUOTE LONGCARDINAL)) (* ; "Type code") (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE (if FILINGP then (QUOTE FILING) else (QUOTE MAILTRANSPORT)) (CADDR TYPEINFO)) else (ERROR "Unknown mail attribute" TYPE))))
)

(\NSMAIL.FINDSERVER
(LAMBDA NIL (* bvm%: "14-Nov-84 23:47") (PROG ((NULL.AUTHENTICATOR (CONSTANT (COURIER.CREATE (AUTHENTICATION . CREDENTIALS) TYPE _ (QUOTE SIMPLE) VALUE _ NIL))) INFO) (RETURN (COND ((AND \NSMAIL.SERVER.CACHE (find ADDR in \NSMAIL.SERVER.CACHE suchthat (\NSMAIL.CHECKSERVER (COURIER.EXPEDITED.CALL ADDR \NSMAIL.SOCKET (QUOTE MAILTRANSPORT) (QUOTE SERVER.POLL) NULL.AUTHENTICATOR (QUOTE (0)) (QUOTE RETURNERRORS)))))) ((SETQ INFO (COURIER.BROADCAST.CALL \NSMAIL.SOCKET (QUOTE MAILTRANSPORT) (QUOTE SERVER.POLL) (LIST NULL.AUTHENTICATOR (QUOTE (0))) (FUNCTION \NSMAIL.CHECKSERVER) NSMAIL.NET.HINT)) (push \NSMAIL.SERVER.CACHE INFO) INFO)))))
)

(\NSMAIL.CHECKSERVER
(LAMBDA (POLLRESULT) (* bvm%: " 1-Jul-84 15:15") (* ;; "Checks that the result of a SERVER.POLL is useful.  Returns the server's address") (COND ((AND (FIXP (CAR POLLRESULT)) (ILESSP (CAR POLLRESULT) 10)) (CAR (CADR POLLRESULT)))))
)
)

(FILESLOAD LAFITEMAIL)



(* ; "for LAFITE.MAKE.PARSE.TABLE")


(RPAQQ NSMAIL.PARSEFIELDS
       (("DATE:" LAFITE.READ.LINE.FOR.TOC Date)
        ("SUBJECT:" LAFITE.READ.LINE.FOR.TOC Subject)
        ("SENDER:" LAFITE.READ.NAME.FIELD Sender)
        ("FROM:" LAFITE.READ.NAME.FIELD From)
        ("REPLY-TO:" LAFITE.READ.NAME.FIELD Reply-to)
        ("IN-REPLY-TO:" LAFITE.READ.LINE.FOR.TOC In-Reply-to)
        ("TO:" LAFITE.READ.NAME.FIELD To)
        ("CC:" LAFITE.READ.NAME.FIELD cc)
        ("FORMAT:" LAFITE.READ.FORMAT)
        ("ATTACHED-REFERENCE:" LAFITE.READ.LINE.FOR.TOC REFERENCE)
        ("ATTACHED-FILE:" LAFITE.READ.LINE.FOR.TOC ATTACHMENT)))

(RPAQ \LAPARSE.NSMAIL (LAFITE.MAKE.PARSE.TABLE NSMAIL.PARSEFIELDS))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \LAPARSE.NSMAIL)
)

(RPAQ? \NSMAIL.SERVER.CACHE )

(RPAQ? NSMAIL.NET.HINT )

(RPAQ? *NSMAIL-MAX-NOTE-LENGTH* 8000)

(RPAQ? *NSMAIL-SEND-MAIL-NOTES* )

(RPAQ? *NSMAIL-CACHE-TIMEOUT* 14400000)

(RPAQ? LAFITEDL.EXT "DL")

(CL:PROCLAIM '(GLOBAL NSMAIL.NET.HINT *NSMAIL-MAX-NOTE-LENGTH* *NSMAIL-SEND-MAIL-NOTES* 
                     *NSMAIL-CACHE-TIMEOUT*))

(ADDTOVAR \SYSTEMCACHEVARS \NSMAIL.SERVER.CACHE)
(DEFINEQ

(\NSMAIL.MESSAGE.P
(LAMBDA (MSG) (* ; "Edited  6-May-88 13:58 by bvm") (AND (STRPOS ":" (fetch (LAFITEMSG FROM) of MSG)) (QUOTE ?)))
)

(\NSMAIL.MESSAGE.FROM.SELF.P
(LAMBDA (MSG) (* ; "Edited  6-May-88 14:37 by bvm") (* ;; "True if message is from current user.  Easy in NS case because we always make the From field be exactly our full name") (STRING-EQUAL (fetch (LAFITEMSG FROM) of MSG) (fetch (LAFITEMODEDATA FULLUSERNAME) of *LAFITE-MODE-DATA*)))
)

(\NSMAIL.MAKEANSWERFORM
(LAMBDA (MSGDESCRIPTORS MAILFOLDER) (* ; "Edited  6-Jun-88 14:09 by bvm") (LET ((MSGFIELDS (\LAFITE.PARSE.MESSAGE MAILFOLDER (OR (CAR (LISTP MSGDESCRIPTORS)) MSGDESCRIPTORS))) SUBJECT FROM DATE SENDER REPLYTO TO CC ORIGINALREGISTRY OLDFROM NEWTO) (* ; "get the fields from the file") (for PAIR in MSGFIELDS do (SELECTQ (CAR PAIR) (Subject (SETQ SUBJECT (CADR PAIR))) (Sender (SETQ SENDER (CADR PAIR))) (From (SETQ FROM (CADR PAIR))) (Date (SETQ DATE (CADR PAIR))) (Reply-to (SETQ REPLYTO (CDR PAIR))) (To (SETQ TO (CDR PAIR))) (cc (SETQ CC (CDR PAIR))) NIL)) (* ; "first parse the strings into recipients") (COND (SENDER (* ; "Sender is a mail address, and has the official registry") (SETQ ORIGINALREGISTRY (PARSE.NSNAME SENDER)) (SETQ OLDFROM (AND FROM (\NSMAIL.PARSE FROM ORIGINALREGISTRY)))) (FROM (* ; "Have to parse the From field before we can get its registry") (SETQ ORIGINALREGISTRY (CAR (SETQ OLDFROM (\NSMAIL.PARSE FROM))))) (T (LAB.PROMPTPRINT MAILFOLDER T "Can't reply--no FROM or SENDER field"))) (SETQ NEWTO (OR (AND REPLYTO (SETQ REPLYTO (\NSMAIL.PARSE REPLYTO ORIGINALREGISTRY))) OLDFROM)) (LAFITE.FILL.IN.ANSWER.FORM SUBJECT FROM DATE NEWTO (CL:SET-DIFFERENCE (COND (REPLYTO (* ; "Only this address, so can only cc to self now") (LIST (fetch (LAFITEMODEDATA UNPACKEDUSERNAME) of *LAFITE-MODE-DATA*))) (T (* ; "Take everyone who got the original, removing duplicates, of course.") (NS.REMOVEDUPLICATES (APPEND (AND TO (\NSMAIL.PARSE TO ORIGINALREGISTRY)) (AND CC (\NSMAIL.PARSE CC ORIGINALREGISTRY)))))) NEWTO :TEST (FUNCTION EQUAL.CH.NAMES)) (FUNCTION \NSMAIL.PRINT.NAMES))))
)
)



(* ; "Utility for handling mail attributes")


(PUTPROPS ENVELOPE.ITEM COURIERDEF (\NS.READ.ENVELOPE.ITEM \NS.WRITE.ENVELOPE.ITEM))
(DEFINEQ

(\NS.READ.ENVELOPE.ITEM
(LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 22-Nov-89 12:11 by bvm") (* ;; "Reads a mailing envelope attribute value pair from STREAM, returning a list of two elements, (TYPE VALUE);  if the attribute is not a known attribute, TYPE is an integer and VALUE is a sequence of unspecified") (LET* ((TYPE (COURIER.READ STREAM NIL (QUOTE LONGCARDINAL))) (VALUETYPE (\COMPUTED.FORM (BQUOTE (CASE TYPE (\,@ (for TRIPLE in \NSMAIL.ENVELOPE.ITEM.TYPES collect (BQUOTE ((\, (CADR TRIPLE)) (SETQ TYPE (QUOTE (\, (CAR TRIPLE)))) (QUOTE (\, (CADDR TRIPLE)))))))))))) (LIST TYPE (if VALUETYPE then (\WIN STREAM) (* ; "Skip sequence count") (COURIER.READ STREAM PROGRAM VALUETYPE) else (COURIER.READ.SEQUENCE STREAM NIL (QUOTE UNSPECIFIED))))))
)

(\NS.WRITE.ENVELOPE.ITEM
(LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 22-Nov-89 12:31 by bvm") (* ;;; "Writes a filing attribute value pair to STREAM.  ITEM is a list of two elements (TYPE VALUE)") (LET ((TYPE (CAR ITEM)) (VALUE (CADR ITEM)) VALUETYPE) (COURIER.WRITE STREAM (OR (FIXP TYPE) (\COMPUTED.FORM (BQUOTE (CASE TYPE (\,@ (for TRIPLE in \NSMAIL.ENVELOPE.ITEM.TYPES collect (BQUOTE ((\, (CAR TRIPLE)) (SETQ VALUETYPE (QUOTE (\, (CADDR TRIPLE)))) (QUOTE (\, (CADR TRIPLE))))))) (T (ERROR "Unknown Envelope Item Type" TYPE)))))) NIL (QUOTE LONGCARDINAL)) (COND (VALUETYPE (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE PROGRAM VALUETYPE)) (T (COURIER.WRITE.SEQUENCE STREAM VALUE PROGRAM (QUOTE UNSPECIFIED))))))
)
)

(RPAQQ \NSMAIL.ENVELOPE.ITEM.TYPES
       ((Postmark 0 POSTMARK)
        (Message-ID 1 MESSAGEID)
        (ContentsType 2 LONGCARDINAL)
        (CONTENTS.SIZE 3 LONGCARDINAL)
        (Originator 4 RNAME)
        (TransportProblem 6 PROBLEM)
        (RETURN.TO.NAME 7 RNAME)
        (Previous-Recipients 8 RNAME.LIST)
        (BodyType 17 LONGCARDINAL)
        (Status 1000 (INBASKET . STATUS))))
(DECLARE%: EVAL@COMPILE DOCOPY 

(RPAQQ \NSMAIL.ATTRIBUTES
       ((From 4672 NAME.LIST)
        (Date 4673 TIME)
        (Reply-to 4674 NAME.LIST)
        (To 4676 NAME.LIST)
        (cc 4677 NAME.LIST)
        (Subject 9 STRING)
        (Message-ID 4693 MESSAGEID)
        (Sender 4705 NAME)
        (BodySize 16 LONGCARDINAL)
        (BodyType 17 LONGCARDINAL)
        (Note 4687 STRING)
        (OldLispFormatting 4910 STRING)
        (LispFormatting 4911 STRING)
        (In-Reply-to 4690 STRING)))
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD NSMAILBOX (NSMAILSTREAM NSMAILENVTAIL NSMAILENVELOPES NSMAILLASTINDEX . NSMAILSTATE)
                      [ACCESSFNS NSMAILBOX ((NSMAILSESSION (fetch STATESESSION
                                                              of (fetch NSMAILSTATE
                                                                        of DATUM)))
                                            (NSMAILFIRSTINDEX (fetch STATEFIRSTNEW
                                                                 of (fetch NSMAILSTATE
                                                                           of DATUM])

(RECORD NSMAILSTATE (STATESESSION STATEFIRSTNEW STATEOLDLAST STATENAME STATECREDENTIALS 
                               STATEADDRESS STATELASTERROR STATETIMER))

(RECORD NSMAILPARSE (NSPSUBJECT NSPRECIPIENTS NSPSTART NSPFORMATTED . NSPFIELDS))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \NSMAIL.SOCKET 26)

(RPAQQ \SERIALIZED.FILE.VERSION 2)

(RPAQQ \SERIALIZED.FILE.VERSIONS (2 3))

(RPAQQ \NSMAIL.CTSTANDARD.MESSAGE 0)

(RPAQQ \NSMAIL.TEXT.BODYTYPE 2)

(RPAQQ \NSMAIL.EMPTY.BODYTYPE 4)

(RPAQQ \NSMAIL.REFERENCE.BODYTYPE 4427)

(RPAQQ MAX.BULK.SEGMENT.LENGTH 32768)

(RPAQQ \NULL.CACHE.VERIFIER (0 0 0 0))


(CONSTANTS \NSMAIL.SOCKET \SERIALIZED.FILE.VERSION \SERIALIZED.FILE.VERSIONS 
       \NSMAIL.CTSTANDARD.MESSAGE \NSMAIL.TEXT.BODYTYPE \NSMAIL.EMPTY.BODYTYPE 
       \NSMAIL.REFERENCE.BODYTYPE MAX.BULK.SEGMENT.LENGTH \NULL.CACHE.VERIFIER)
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS \NSMAIL.ATTRIBUTE.TYPE MACRO [ARGS (COND
                                                        ((CADR (ASSOC (CAR ARGS)
                                                                      \NSMAIL.ATTRIBUTES)))
                                                        (T (ERROR "Unknown mail attribute"
                                                                  (CAR ARGS))
                                                           'IGNOREMACRO])

(PUTPROPS \NSMAIL.WRITE.ATTRIBUTE MACRO
          [ARGS (LET [(INFO (CDR (ASSOC (CAR (CONSTANTEXPRESSIONP (CADR ARGS)))
                                        \NSMAIL.ATTRIBUTES]
                     (COND
                        [INFO (LIST '\NSMAIL.WRITE.ATTRIBUTE.MACRO (CAR ARGS)
                                    (CAR INFO)
                                    (CADDR ARGS)
                                    (KWOTE (CADR INFO]
                        (T 'IGNOREMACRO])

(PUTPROPS \NSMAIL.WRITE.ATTRIBUTE.MACRO MACRO (OPENLAMBDA (STREAM TYPENO VALUE VALUETYPE)
                                                             (COURIER.WRITE STREAM TYPENO NIL
                                                                    'LONGCARDINAL)
                                                             (COURIER.WRITE.SEQUENCE.UNSPECIFIED
                                                              STREAM VALUE 'MAILTRANSPORT VALUETYPE)))
)


(PUTPROPS \NSMAIL.ATTRIBUTE.TYPE INFO NOEVAL)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS NSMAIL.NET.HINT \NSMAIL.ENVELOPE.ITEM.TYPES \NSMAIL.ATTRIBUTES \NSMAIL.SERVER.CACHE 
       NSMAILDEBUGFLG NSWIZARDFLG NSMAIL.LEAVE.ATTACHMENTS \NSMAIL.GOOD.BODYTYPES 
       MAILOBJ.WINDOWOFFSET MAILOBJ.SKIPCHAR \MAILOBJ.IMAGEFNS MAILOBJ.REFERENCE.FIELD 
       \NSFILING.ATTRIBUTES DEFAULTICONFONT NSPRINT.WATCHERFLG NSMAIL.HEADER.ORDER FILING.TYPES)
)


(CL:PROCLAIM '(CL:SPECIAL *RETRIEVAL-ERROR*))


(FILESLOAD (SOURCE)
       LAFITEDECLS)


(FILESLOAD (LOADCOMP)
       CLEARINGHOUSE)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA INBASKET.CALL)
)
(PUTPROPS NSMAIL COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (15176 18023 (\NSMAIL.AUTHENTICATE 15186 . 16404) (\NSMAIL.MAKE.MAILSERVERS 16406 . 
17334) (\NSMAIL.LOGIN 17336 . 17562) (NS.FINDMAILBOXES 17564 . 18021)) (18335 59849 (NS.POLLNEWMAIL 
18345 . 19228) (NS.OPENMAILBOX 19230 . 21228) (\NSMAIL.CHECK 21230 . 32463) (
\NSMAIL.FIX.MAILBOX.LOCATIONS 32465 . 36016) (NS.NEXTMESSAGE 36018 . 36929) (\NSMAIL.READ.ENVELOPES 
36931 . 38905) (INBASKET.CALL 38907 . 40247) (NS.RETRIEVEMESSAGE 40249 . 45307) (\NSMAIL.RETRIEVE 
45309 . 47078) (\NSMAIL.EOF.ON.RETRIEVE 47080 . 47430) (\NSMAIL.READ.SERIALIZED.TREE 47432 . 51396) (
\NSMAIL.CHECK.SERIALIZED.VERSION 51398 . 51711) (\NSMAIL.READ.SERIALIZED.CONTENT 51713 . 52607) (
\NSMAIL.DISCARD.SERIALIZED.CONTENT 52609 . 53056) (\NSMAIL.READ.STRING.AS.STREAM 53058 . 53467) (
\NSMAIL.PRINT.HEADERFIELDS 53469 . 58947) (\NSMAIL.PRINT.NAMES 58949 . 59847)) (59881 61895 (
\NSMAIL.COURIER.OPEN 59891 . 60094) (\NSMAIL.ERRORHANDLER 60096 . 60518) (\NSMAIL.SIGNAL.ERROR 60520
 . 61893)) (61933 65545 (NS.CLOSEMAILBOX 61943 . 63668) (\NSMAIL.LOGOFF 63670 . 64710) (
\NSMAIL.CHANGE.STATUS 64712 . 65543)) (65827 72849 (\MAILOBJ.CREATE 65837 . 68062) (\MAILOBJ.TYPE.NAME
 68064 . 68531) (\MAILOBJ.NS.TO.LISP.NAME 68533 . 69884) (\MAILOBJ.DISPLAY 69886 . 70464) (
\MAILOBJ.GET 70466 . 71289) (\MAILOBJ.IMAGEBOX 71291 . 71496) (\MAILOBJ.PUT 71498 . 72569) (
\MAILOBJ.INIT 72571 . 72847)) (72850 98554 (\MAILOBJ.BUTTONEVENTFN 72860 . 77169) (\MAILOBJ.DO.COMMAND
 77171 . 77418) (\MAILOBJ.HARDCOPY 77420 . 81186) (\MAILOBJ.FB 81188 . 81466) (\MAILOBJ.PUT.FILE 81468
 . 84817) (\MAILOBJ.VIEW 84819 . 90235) (\MAILOBJ.MUNGE.NAME 90237 . 90501) (\MAILOBJ.COPY.BODY 90503
 . 90817) (\MAILOBJ.EXPAND 90819 . 94981) (\MAILOBJ.COPY.CHILD 94983 . 96340) (\MAILOBJ.COPY.SEQUENCE 
96342 . 96710) (\MAILOBJ.EXTRACT.TEXT 96712 . 97773) (\MAILOBJ.PARSE.ATTRIBUTES 97775 . 98552)) (99976
 122547 (\NSMAIL.SEND.PARSE 99986 . 101938) (\NSMAIL.PARSE.REFERENCE 101940 . 103858) (
\NSMAIL.EXPAND.DL 103860 . 104927) (\NSMAIL.PARSE 104929 . 105190) (\NSMAIL.PARSE1 105192 . 105760) (
NS.REMOVEDUPLICATES 105762 . 105900) (\NSMAIL.SEND 105902 . 112999) (\NSMAIL.PREPARE.ATTACHMENT 113001
 . 115686) (\NSMAIL.GUESS.FILE.TYPE 115688 . 116189) (\NSMAIL.SEND.MESSAGE.CONTENT 116191 . 119224) (
COURIER.WRITE.STREAM.UNSPECIFIED 119226 . 120370) (\NSMAIL.SEND.STREAM.AS.STRING 120372 . 120992) (
\NSMAIL.WRITE.ATTRIBUTE 120994 . 121619) (\NSMAIL.FINDSERVER 121621 . 122285) (\NSMAIL.CHECKSERVER 
122287 . 122545)) (123769 125868 (\NSMAIL.MESSAGE.P 123779 . 123917) (\NSMAIL.MESSAGE.FROM.SELF.P 
123919 . 124240) (\NSMAIL.MAKEANSWERFORM 124242 . 125866)) (126016 127515 (\NS.READ.ENVELOPE.ITEM 
126026 . 126783) (\NS.WRITE.ENVELOPE.ITEM 126785 . 127513)))))
STOP
\ No newline at end of file
diff --git a/internal/library/NSMAIL.TEDIT b/internal/library/NSMAIL.TEDIT
new file mode 100644
index 00000000..28f66464
Binary files /dev/null and b/internal/library/NSMAIL.TEDIT differ
diff --git a/internal/library/NSTOASCIIDISPLAYFONT b/internal/library/NSTOASCIIDISPLAYFONT
new file mode 100644
index 00000000..66dd4714
--- /dev/null
+++ b/internal/library/NSTOASCIIDISPLAYFONT
@@ -0,0 +1 @@
+(FILECREATED "26-Feb-85 10:13:25" {ERIS}<LISPCORE>LIBRARY>NSTOASCIIDISPLAYFONT.;7 8948   

      changes to:  (FNS ASCIIDISPLAYFONT NSTOASCIIDISPLAYFONT)
		   (VARS NSTOASCIIDISPLAYFONTCOMS ASCIITOACCENTARRAY)

      previous date: "28-Nov-84 22:57:10" {ERIS}<LISPCORE>LIBRARY>NSTOASCIIDISPLAYFONT.;2)


(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT NSTOASCIIDISPLAYFONTCOMS)

(RPAQQ NSTOASCIIDISPLAYFONTCOMS ((FNS ASCIIDISPLAYFONT NSTOASCIIDISPLAYFONT READNSDISPLAYFONTFILE)
				 (FILES (FROM VALUEOF LISPUSERSDIRECTORIES)
					EDITFONT)
				 (ALISTS (ASCIITONSTRANSLATIONS CLASSICACCENTS MODERNACCENTS))
				 (VARS ASCIITOACCENTARRAY)))
(DEFINEQ

(ASCIIDISPLAYFONT
  [LAMBDA (FAMILY SIZE FACE ROTATION)                        (* rmk: "26-Feb-85 10:13")
    (PROG [TEMP (TRANSL (CDR (ASSOC (SETQ FAMILY (U-CASE FAMILY))
				    ASCIITONSTRANSLATIONS]
          (OR TRANSL (ERROR "No translation information for " FAMILY))
          (RETURN (NSTOASCIIDISPLAYFONT (COND
					  ((NULL (SETQ TEMP (CAR TRANSL)))
					    \ASCIITONS)
					  ((LITATOM TEMP)
					    (EVAL TEMP))
					  (T TEMP))
					(COND
					  ((NULL (SETQ TEMP (CADDR TRANSL)))
					    \ASCIITOSTAR)
					  ((LITATOM TEMP)
					    (EVAL TEMP))
					  (T TEMP))
					FAMILY
					(OR (CADR TRANSL)
					    (QUOTE MODERN))
					SIZE
					(\FONTFACE FACE)
					(OR ROTATION 0])

(NSTOASCIIDISPLAYFONT
  [LAMBDA (ASCIITONSMAPARRAY ASCIITONSFIXARRAY ASCIIFAMILY NSFAMILY SIZE FONTFACE ROTATION DEVICE)
                                                             (* rmk: "26-Feb-85 09:50")
                                                             (* Produces an ASCII displayfont by getting bitmaps and
							     widths from NS character sets, as determined by the 
							     translation table)
                                                             (* ASCIITONSFIXARRAY is for temporary problems with 
							     font compatibility between printer and widths/screen.
							     in OS5.0 fonts)
    (PROG [CHARSETDIR FD (ASCIITONSMAP (fetch (ARRAYP BASE) of (\DTEST (OR ASCIITONSFIXARRAY 
									   ASCIITONSMAPARRAY)
								       (QUOTE ARRAYP]
          [for I NSCODE CS from 0 to 255 unless (OR (EQ 0 (SETQ NSCODE (\GETBASE ASCIITONSMAP I)))
						    (ASSOC (SETQ CS (NSCHARSET NSCODE))
							   CHARSETDIR))
	     do                                              (* Run thru the translate table looking for non-0 
							     charsets. Add their width info to the directory)
		(push CHARSETDIR (CONS CS
				       (COND
					 ((READNSDISPLAYFONTFILE NSFAMILY SIZE FONTFACE CS))
					 (T                  (* There isn't any info for that character.
							     Warn the guy, but continue.)
					    (FRESHLINE PROMPTWINDOW)
					    (printout PROMPTWINDOW 
						     "Warning:  Information about character set "
						      .I3.8 CS " missing from font " ASCIIFAMILY , 
						      SIZE ".")
					    NIL]             (* Return if one of the fonts couldn't be found)
          [SETQ FD (for C in CHARSETDIR largest (FONTPROP (CDR C)
							  (QUOTE HEIGHT]
                                                             (* Choose FD with maximum height to modify and return)
          (SETQ CHARSETDIR (DREMOVE FD CHARSETDIR))
          (SETQ FD (CDR FD))
          (for C CFD OLDBM NEWBM (FDH _(FONTPROP FD (QUOTE HEIGHT)))
	       (FDD _(FONTPROP FD (QUOTE DESCENT))) in CHARSETDIR unless (EQ FDH (FONTPROP
									       (CDR C)
									       (QUOTE HEIGHT)))
	     do (SETQ CFD (CDR C))
		(if (EQ FDD (FONTPROP CFD (QUOTE DESCENT)))
		    then (SETQ OLDBM (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of CFD)) 
                                                             (* If Descents agree, then just coerce the height 
							     upwards.)
			 (SETQ NEWBM (BITMAPCREATE (BITMAPWIDTH OLDBM)
						   FDH))
			 (BITBLT OLDBM 0 0 NEWBM)
			 (replace (FONTDESCRIPTOR CHARACTERBITMAP) of CFD with NEWBM)
			 (replace (FONTDESCRIPTOR \SFHeight) of CFD with FDH)
		  else                                       (* If descents disagree, then not sure how to align 
							     them)
		       (HELP "Mismatch of font heights and descents")))
          (bind CHARSETINFO for I NSCODE from 0 to 255 unless (EQ 0 (SETQ NSCODE (\GETBASE 
										     ASCIITONSMAP I)))
	     when (SETQ CHARSETINFO (CDR (ASSOC (NSCHARSET NSCODE)
						CHARSETDIR)))
	     do                                              (* For each non-ASCII character, look for width info in
							     the right NS place. If none, use zero width.)
		(PUTCHARBITMAP I FD (GETCHARBITMAP (NSCHAR NSCODE)
						   CHARSETINFO)))
          (RETURN FD])

(READNSDISPLAYFONTFILE
  [LAMBDA (FAMILY SIZE FACE CHARSET)                         (* rmk: "28-Nov-84 22:25")
    (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES))
    (SELECTQ (SYSTEMTYPE)
	     (J (PROG ((FONTFILE (\FONTFILENAME FAMILY SIZE FACE))
		       FONTDESC STRM)
		      (COND
			((SETQ STRM (AND FONTDIRECTORIES (FINDFILE FONTFILE T FONTDIRECTORIES)))
			  (SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT)))
			  (SETQ FONTDESC (\READJERICHOFONTFILE FAMILY SIZE FACE STRM))
			  (CLOSEF STRM)))
		      (replace FONTSCALE of FONTDESC with 1)
		      (RETURN FONTDESC)))
	     [D (for E FONTFILE FONTDESC STRM inside DISPLAYFONTEXTENSIONS
		   when (SETQ FONTFILE (FINDFILE (\FONTFILENAME FAMILY SIZE FACE E CHARSET)
						 T DISPLAYFONTDIRECTORIES))
		   do (SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT)))
		      [RESETLST (SETQ FONTDESC (SELECTQ (FONTFILEFORMAT STRM T)
							(STRIKE (RESETSAVE
								  NIL
								  (LIST (FUNCTION CLOSEF)
									STRM))
								(\READSTRIKEFONTFILE STRM FAMILY SIZE 
										     FACE))
							(AC 
                                                             (* CLOSEF is guaranteed inside \READACFONTFILE, against
							     the possibility that we have to copy to make 
							     randaccessp)
							    (\READACFONTFILE STRM FAMILY SIZE FACE))
							(PROG1 (CLOSEF STRM)
                                                             (* This would get done by RESETSAVE if AC's were read 
							     sequentially and we could factor the RESETSAVE)
							       ]

          (* If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also 
	  be nice to tell the user that he has a bogus file.)


		      (COND
			(FONTDESC (replace FONTSCALE of FONTDESC with 1)
				  (RETURN FONTDESC]
	     (SHOULDNT])
)
(FILESLOAD (FROM VALUEOF LISPUSERSDIRECTORIES)
	   EDITFONT)

(ADDTOVAR ASCIITONSTRANSLATIONS (CLASSICACCENTS ASCIITOACCENTARRAY CLASSIC ASCIITOACCENTARRAY)
				(MODERNACCENTS ASCIITOACCENTARRAY MODERN ASCIITOACCENTARRAY))

(RPAQ ASCIITOACCENTARRAY (READARRAY 256 (QUOTE SMALLPOSP) 0))
(0 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 27 28 29 30 31 32 61729 61730 
61731 61732 61733 61734 61735 61736 61737 61738 61739 61740 61741 61742 61743 61744 61745 61746 61747 
61748 61749 61750 61751 61752 61753 61754 61755 61756 61757 61758 61759 61760 61761 61762 61763 61764 
61765 61766 61767 61768 61769 61770 61771 61772 61773 61774 61775 61776 61777 61778 61779 61780 61781 
61782 61783 61784 61785 61786 61787 61788 61789 61790 61791 61792 61793 61794 61795 61796 61797 61798 
61799 61800 61801 61802 61803 61804 61805 61806 61807 61808 113 114 115 116 117 118 119 120 121 122 
123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 
148 149 150 151 152 153 154 155 156 157 158 159 160 61857 61858 61859 61860 61861 61862 61863 61864 
61865 61866 61867 61868 61869 61870 61871 61872 61873 61874 61875 61876 61877 61878 61879 61880 61881 
61882 61883 61884 61885 61886 61887 61888 61889 61890 61891 61892 61893 61894 61895 61896 61897 61898 
61899 61900 61901 61902 61903 61904 61905 61906 61907 61908 61909 61910 61911 61912 61913 61914 61915 
61916 61917 61918 61919 61920 61921 61922 61923 61924 61925 61926 61927 61928 61929 61930 61931 61932 
61933 61934 61935 61936 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 NIL
)
(PUTPROPS NSTOASCIIDISPLAYFONT COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (692 7242 (ASCIIDISPLAYFONT 702 . 1508) (NSTOASCIIDISPLAYFONT 1510 . 5183) (
READNSDISPLAYFONTFILE 5185 . 7240)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/AR-11348-PATCH b/internal/library/OBSOLETE/AR-11348-PATCH
new file mode 100644
index 00000000..40a10df8
--- /dev/null
+++ b/internal/library/OBSOLETE/AR-11348-PATCH
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Mar-91 18:37:25" {DSK}<home>crea>mitani>medley>ar>fuji>AR-11348-PATCH.;3 12223  

      changes to%:  (FNS \UFSDirectoryNameP \UFSGetPrintFileType \UFS.NEXTFILEFN \UFS.FULLNAME \UFSParseNameString)
 (VARS AR-11348-PATCHCOMS))


(* ; "
Copyright (c) 1991 by Fuji Xerox Co., Ltd.  All rights reserved.
")

(PRETTYCOMPRINT AR-11348-PATCHCOMS)

(RPAQQ AR-11348-PATCHCOMS ((FNS \UFS.REMOVE.HOST.FIELD \UFSDirectoryNameP \UFSGenerateFiles \UFSGetFileInfo \UFSSetFileInfo \UFSGetPrintFileType \UFS.NEXTFILEFN \UFS.FULLNAME \UFSParseNameString)))
(DEFINEQ

(\UFS.REMOVE.HOST.FIELD
(LAMBDA (FILE DEV) (* ; "Edited 20-Mar-91 16:52 by nm") (* ;; "Accepts a full file representation, and returns the file representaion as a string in which HOST field is removed.") (LET* ((PARSE-LIST (\UFSParseNameString FILE)) (RELATIVEDIRECTORY (MEMB (QUOTE RELATIVEDIRECTORY) PARSE-LIST)) (DIRECTORY (LISTGET PARSE-LIST (QUOTE DIRECTORY))) PACKED-NAME VERSION) (if (DSKP DEV) then (* ;; " Check if FILE contains the valid version field or not so that C code can assume that all file names are valid.") (AND (SETQ VERSION (LISTGET PARSE-LIST (QUOTE VERSION))) (if (STREQUAL VERSION "") then (* ;; "Newest version is specifed.   Just removes it.") (LISTPUT PARSE-LIST (QUOTE VERSION) NIL) else (OR (FIXP (MKATOM VERSION)) (CL:ERROR (QUOTE XCL:INVALID-PATHNAME) :PATHNAME FILE))))) (if RELATIVEDIRECTORY then (RPLACA (CDR RELATIVEDIRECTORY) (\UFS.HANDLE.RELATIVEDIRECTORY (CADR RELATIVEDIRECTORY) DEV)) elseif (NOT DIRECTORY) then (LISTPUT PARSE-LIST (QUOTE DIRECTORY) (\UFS.DEFAULT.DIR DEV))) (LISTPUT PARSE-LIST (QUOTE HOST) NIL) (SETQ PACKED-NAME (PACKFILENAME.STRING PARSE-LIST)) (if (STREQUAL (LISTGET PARSE-LIST (QUOTE DIRECTORY)) "<") then (if (LISTGET PARSE-LIST (QUOTE NAME)) then (SUBSTRING PACKED-NAME 2) else "<") else (if (EQ (NTHCHARCODE PACKED-NAME 1) (CHARCODE <)) then (SUBSTRING PACKED-NAME 2) else PACKED-NAME))))
)

(\UFSDirectoryNameP
(LAMBDA (DIRSPEC DEV) (* ; "Edited 22-Mar-91 18:22 by nm") (* ;;; " DIRECTORYNAMEP FDEV method.   Performs a recognition as well and returns the %"true%" name if it exists.") (LET* ((PARSED-LIST (\UFSParseNameString DIRSPEC (QUOTE RETURN))) (DIRECTORY (OR (LISTGET PARSED-LIST (QUOTE DIRECTORY)) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED-LIST (QUOTE RELATIVEDIRECTORY)) DEV) (\UFS.DEFAULT.DIR DEV))) NAMEAREA LEN) (* ;; " HOST field of DIRSPEC has been defaulted by the generic file system code.  Thus we don't have to worry about the subdirectory case.") (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.") (SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV)) (COND ((FIXP LEN) (* ; "LEN holds the length of the %"true%" name of DIRECTORY.") (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN) DEV NIL)) (T NIL))))
)

(\UFSGenerateFiles
(LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 20-Mar-91 17:08 by nm") (* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG* ((PARSED (\UFSParseNameString PATTERN)) (DIRECTORY (OR (LISTGET PARSED (QUOTE DIRECTORY)) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED (QUOTE RELATIVEDIRECTORY)) FDEV) (\UFS.DEFAULT.DIR FDEV))) (NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) FILTER LEN) (if (STREQUAL DIRECTORY "/") then (SETQ DIRECTORY "<")) (SETQ FILTER (if (STREQUAL DIRECTORY "<") then (CONCAT "{" (LISTGET PARSED (QUOTE HOST)) "}" "<" (PACKFILENAME.STRING (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*"))) else (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRECTORY (QUOTE HOST) (LISTGET PARSED (QUOTE HOST)) (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*")))) (SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA FDEV)) (if (NOT (FIXP LEN)) then (* ; "No such directory.  We go thru this recognition step so that \UFSFindFile gives us name in the correct case") (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory") (RETURN (\NULLFILEGENERATOR))) (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ;; "The information about enumerated files are cached in the emulator.  We receive the ID and the total number of enumerated files.  The ID is used to identify the object corresponding to the enumerated file.") (LET ((ID (CREATECELL \FIXP)) (ERRNO (CREATECELL \FIXP)) (PROPP (\UFS.VALID.PROPP DESIREDPROPS)) TOTALNUM) (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) (if (< TOTALNUM 0) then (OR (\UFSError DIRECTORY ERRNO FDEV) (RETURN (\NULLFILEGENERATOR))) else (if (ZEROP TOTALNUM) then (RETURN (\NULLFILEGENERATOR)) else (AND (OR (AND (NOT (LISTP OPTIONS)) (EQ OPTIONS (QUOTE RESETLST))) (FMEMB (QUOTE RESETLST) OPTIONS)) (RESETSAVE NIL (QUOTE (AND RESETSTATE (\UFSFinishFileInfo-C ID))))) (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN) GENFILESTATE _ (\UFS.REGISTER.GFS (create UFSGENFILESTATE FINFOID _ ID FILEID _ 0 TOTALNUM _ TOTALNUM DIRECTORY _ DIRECTORY DEV _ FDEV PROPP _ PROPP NAME _ (ALLOCSTRING MAX-PATHNAME-LEN) AUTHOR _ (AND PROPP (ALLOCSTRING MAX-UNAME-LEN))))))))))))
)

(\UFSGetFileInfo
(LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 20-Mar-91 20:17 by nm") (* ;;; "Get the value of the attribute for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTHOR, the type of the buffer is STRING.") (* ;;; "Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.ADD.HOST.FIELD (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE) (if FILENAME then (SELECTQ ATTRIBUTE (LENGTH (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (SIZE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then (FOLDHI BUFFER BYTESPERPAGE) else (\UFSError FILENAME ERRNO DEVICE))) (TYPE (\UFSGetFileType FILENAME)) ((CREATIONDATE WRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) (READDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) ((ICREATIONDATE IWRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (IREADDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER ERRNO)) then (CL:SUBSEQ BUFFER 0 NAMESIZE) else (\UFSError FILENAME ERRNO DEVICE))) (PROTECTION (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (ALL (SETQ BUFFER (\UFS.CREATE.PROPS)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-ALL BUFFER ERRNO)) then (LET ((ALIST (ASSOC (QUOTE AUTHOR) BUFFER))) (* ; "Copy string out of buffer") (RPLACD ALIST (CL:SUBSEQ (CDR ALIST) 0 NAMESIZE)) BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) NIL)))))
)

(\UFSSetFileInfo
(LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 20-Mar-91 20:17 by nm") (* ;;; "Get the VALUE of the ATTRIBUTE for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTOR, the type of the buffer is STRING.") (* ;;; " Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.ADD.HOST.FIELD (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE PATHNAME) (if FILENAME then (SELECTQ ATTRIBUTE (TYPE (\UFSSetFileType FILENAME VALUE)) ((CREATIONDATE WRITEDATE) (if (AND (STRINGP VALUE) (SETQ VALUE (IDATE VALUE))) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) ((ICREATIONDATE IWRITEDATE) (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) (PROTECTION (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-PROTECTION VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) NIL)))))
)

(\UFSGetPrintFileType
(LAMBDA (FILENAME) (* ; "Edited 22-Mar-91 18:30 by nm") (COND ((OR (NOT (STREAMP FILENAME)) (SETQ FILENAME (fetch (STREAM FULLFILENAME) of FILENAME))) (LET ((TYPE (UNPACKFILENAME.STRING FILENAME (QUOTE EXTENSION)))) (SETQ TYPE (COND ((AND (EQ (NCHARS TYPE) 0) (CDR (CL:ASSOC NIL DEFAULTFILETYPELIST)))) ((CDR (CL:ASSOC TYPE DEFAULTFILETYPELIST :TEST (QUOTE STRING-EQUAL)))) (T (\UFSGetFileTypeConfirm FILENAME)))) (SELECTQ TYPE ((TEXT BINARY) TYPE) (CL:ERROR "Invalid File Type ~A for ~A" TYPE FILENAME))))))
)

(\UFS.NEXTFILEFN
(LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 22-Mar-91 18:29 by nm") (LET* ((FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE)) (FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE)) (ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE))) FILENAME NAMELEN NEWNAME) (AND (> FINFOID -1) (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (CL:UNWIND-PROTECT (if (> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) 0) then (replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with (SETQ FILENAME (\UFS.FULLNAME (SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of GENFILESTATE) 0 NAMELEN)) (fetch (UFSGENFILESTATE DEV) of GENFILESTATE) NIL (fetch (UFSGENFILESTATE DIRECTORY) of GENFILESTATE)))) (if (= (add FILEID 1) (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) then (* ; "Generator exhausted. ") (\UFS.UNREGISTER.GFS GENFILESTATE T) else (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID)) (if NAMEONLY then NEWNAME else FILENAME)) (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T))))))
)

(\UFS.FULLNAME
(LAMBDA (NAME DEV ATOMP DIRECTORY) (DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*)) (* ; "Edited 22-Mar-91 18:35 by nm") (* ;; "NAME is a name string returned from UNIX.  We turn it into a Lisp %"full file name%".  This function is redefinable by code that hacks ufs names.") (if NAME then (* ; "Pass NIL thru transparently") (if (DSKP DEV) then (SETQ NAME (CL:CONCATENATE (QUOTE STRING) *DSK-HOST-NAME* DIRECTORY NAME)) (if *DSK-UPPER-CASE-FILE-NAMES* then (* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*.  I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines.  Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074).  There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.") (if ATOMP then (MKATOM (U-CASE NAME)) else (U-CASE NAME)) else (if ATOMP then (MKATOM NAME) else NAME)) else (SETQ NAME (CL:CONCATENATE (QUOTE STRING) *UFS-HOST-NAME* DIRECTORY NAME)) (if ATOMP then (MKATOM NAME) else NAME))))
)

(\UFSParseNameString
(LAMBDA (FILE DIRFLG) (* ; "Edited 22-Mar-91 18:19 by nm") (* ;; "\UFS.ADJUST.HOST is a hook for NFS module") (\UFS.ADJUST.HOST (UNPACKFILENAME.STRING FILE NIL DIRFLG)))
)
)
(PUTPROPS AR-11348-PATCH COPYRIGHT ("Fuji Xerox Co., Ltd" 1991))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (625 12135 (\UFS.REMOVE.HOST.FIELD 635 . 1996) (\UFSDirectoryNameP 1998 . 2970) (
\UFSGenerateFiles 2972 . 5532) (\UFSGetFileInfo 5534 . 7818) (\UFSSetFileInfo 7820 . 9051) (
\UFSGetPrintFileType 9053 . 9589) (\UFS.NEXTFILEFN 9591 . 10649) (\UFS.FULLNAME 10651 . 11935) (
\UFSParseNameString 11937 . 12133)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/CLMAIL b/internal/library/OBSOLETE/CLMAIL
new file mode 100644
index 00000000..d7a3c042
--- /dev/null
+++ b/internal/library/OBSOLETE/CLMAIL
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "14-Jun-90 20:54:42" {DSK}<usr>local>lde>lispcore>internal>library>CLMAIL.;2 17296  

      changes to%:  (VARS CLMAILCOMS)
                    (FNS CLMAILSHOW CLMAILDISPLAY CLMAILDISPLAYMSG CLMAILSEARCH CLMAILMSGHASH 
                         CLMAILMERGE CLMAILREDOMENU CLMAILHEADSTRING CLMAILFIRST CLMAILLAST CLMAILFWD
                         CLMAILBKWD CLMAILQUIT MAKECMLHEADHASH MAKECMLMAILHASH UPDATEHASHFILES 
                         CMLMAIL1 CMLMAIL2 CMLMAIL3 CMLMAIL4 CMLMAIL5 CMLMAIL6 CMLMAIL7 CMLMAIL8 
                         CMLMAIL9 CMLMAIL0)

      previous date%: "23-Jan-87 16:37:36" {DSK}<usr>local>lde>lispcore>internal>library>CLMAIL.;1)


(* ; "
Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT CLMAILCOMS)

(RPAQQ CLMAILCOMS
       ((FNS CLMAILSHOW CLMAILDISPLAY CLMAILDISPLAYMSG CLMAILSEARCH CLMAILMSGHASH CLMAILMERGE 
             CLMAILREDOMENU CLMAILHEADSTRING CLMAILFIRST CLMAILLAST CLMAILFWD CLMAILBKWD CLMAILQUIT 
             MAKECMLHEADHASH MAKECMLMAILHASH UPDATEHASHFILES CMLMAIL1 CMLMAIL2 CMLMAIL3 CMLMAIL4 
             CMLMAIL5 CMLMAIL6 CMLMAIL7 CMLMAIL8 CMLMAIL9 CMLMAIL0)
        (VARS CLM.MENUFORMAT (* "Format list for Free Menu")
              CLM.MAILHASHNAME CLM.HEADHASHNAME (* "Names of hashfiles")
              CLM.MAILDATANAME CLM.HEADDATANAME (* "Names of unhashed data files")
              CLM.VAXCDIR CLM.MSGDIR (* "Names of magic directories"))
        (GLOBALVARS CLM.HEADITEMS (* 
                    "A pointer to the first message menu item in CLM.MENUFORMAT for easy referencing"
                                     )
               CLM.ABOVEITEM CLM.BELOWITEM CLM.WORD (* "Points at Above:, Below:, and THEWORD fields"
                                                       )
               CLM.MSGHASH CLM.HEADHASH (* "Streams for message and head line hash files")
               CLM.MENUWINDOW
               (* "The menu window")
               CLM.HEADARRAY CLM.HEAD# (* "Array of head lines for menu and an index into it"))))
(DEFINEQ

(CLMAILSHOW
  [LAMBDA NIL                                            (* "Pavel" "29-May-86 15:52")

         (* * "First, open the the hash files")

    (SETQ CLM.MSGHASH (OPENHASHFILE CLM.MAILHASHNAME 'INPUT))
    (SETQ CLM.HEADHASH (OPENHASHFILE CLM.HEADHASHNAME 'INPUT))

         (* * "Then create the menu window")

    (SETQ CLM.MENUWINDOW (FREEMENU CLM.MENUFORMAT))

         (* * 
    "Set various pointers into the FM.ITEMS list so we can find the first message menu item easily")

    [LET [(WP (WINDOWPROP CLM.MENUWINDOW 'FM.ITEMS]
         [SETQ CLM.WORD (for X in WP thereis (EQ 'THEWORD (FM.ITEMPROP X 'ID]
         [SETQ CLM.HEADITEMS (for X on WP thereis (EQ 'LINE1 (FM.ITEMPROP (CAR X)
                                                                                'ID]
         [SETQ CLM.ABOVEITEM (for X in WP thereis (EQ 'ABOVEFIELD (FM.ITEMPROP
                                                                               X
                                                                               'ID]
         (SETQ CLM.BELOWITEM (for X in WP thereis (EQ 'BELOWFIELD (FM.ITEMPROP
                                                                               X
                                                                               'ID]

         (* * "Finally let user move the menu window (which will open it as a nice side effect)")

    (MOVEW CLM.MENUWINDOW (GETBOXPOSITION (WINDOWPROP CLM.MENUWINDOW 'WIDTH)
                                 (WINDOWPROP CLM.MENUWINDOW 'HEIGHT)
                                 100 100 NIL "Specify the position of the menu window"))
    (OPENW CLM.MENUWINDOW])

(CLMAILDISPLAY
  [LAMBDA (SLOT#)                                        (* jrb%: "29-Oct-86 12:39")
    (LET ((MSG# (+ SLOT# CLM.HEAD#)))
         (CL:UNLESS (> MSG# (ARRAYSIZE CLM.HEADARRAY))
             (CLMAILDISPLAYMSG (CAR (ELT CLM.HEADARRAY MSG#))))])

(CLMAILDISPLAYMSG
  [LAMBDA (MSG)                                          (* jrb%: "29-Oct-86 12:39")
    (if (NUMBERP MSG)
        then (TEDIT (MKATOM (CONCAT CLM.MSGDIR MSG)))
      else (ERROR "This isn't a CL message number" MSG])

(CLMAILSEARCH
  [LAMBDA NIL                                            (* jrb%: "22-Aug-86 14:24")
    (LET [(MSGS (CLMAILMERGE (FM.ITEMPROP CLM.WORD 'LABEL]
         (if MSGS
             then (SETQ CLM.HEADARRAY (ARRAY (LENGTH MSGS)
                                                 'POINTER))
                   (for I from 1 to (ARRAYSIZE CLM.HEADARRAY)
                      do (SETA CLM.HEADARRAY I (pop MSGS)))
                   (SETQ CLM.HEAD# 1)
                   (CLMAILLAST)
           else (FM.CHANGELABEL CLM.WORD "Sorry, that word isn't indexed" CLM.MENUWINDOW])

(CLMAILMSGHASH
  [LAMBDA (WORD)                                         (* jrb%: "29-Oct-86 12:38")
    (if (CL:SYMBOLP WORD)
        then (GETHASHFILE WORD CLM.MSGHASH)
      else (CL:ERROR "~S is not a word" WORD])

(CLMAILMERGE
  [LAMBDA (STRING)                                       (* ; "Edited 23-Jan-87 16:37 by jrb:")
    (LET ((STRINGSTREAM (CL:MAKE-STRING-INPUT-STREAM STRING))
          TERM TERMLIST (RESULT 'FIRSTTIME))
         (while (NOT (EOFP STRINGSTREAM))
            do (CL:TYPECASE (SETQ TERM (READ STRINGSTREAM))
                       (CL:SYMBOL (SETQ TERMLIST (CLMAILMSGHASH TERM)))
                       (LIST 
                          (SETQ TERMLIST NIL)
                          (for TR in TERM do (SETQ TERMLIST (UNION (CLMAILMSGHASH
                                                                                TR)
                                                                               TERMLIST))))
                       (T (CL:ERROR "~S is not a word or list of words" TERM)))
                  (SETQ RESULT (if (EQ RESULT 'FIRSTTIME)
                                   then TERMLIST
                                 else (INTERSECTION TERMLIST RESULT)))
                  (if (NULL RESULT)
                      then (RETURN NIL)))
         RESULT])

(CLMAILREDOMENU
  [LAMBDA NIL                                            (* jrb%: "17-May-86 00:21")
    (FM.CHANGELABEL CLM.ABOVEITEM (SUB1 CLM.HEAD#)
           CLM.MENUWINDOW)
    (FM.CHANGELABEL CLM.BELOWITEM (MAX 0 (IDIFFERENCE (ARRAYSIZE CLM.HEADARRAY)
                                                (IPLUS CLM.HEAD# 9)))
           CLM.MENUWINDOW)
    (for ITM in CLM.HEADITEMS bind (APTR _ CLM.HEAD#) do (FM.CHANGELABEL ITM
                                                                                (CLMAILHEADSTRING
                                                                                 APTR)
                                                                                CLM.MENUWINDOW)
                                                                        (SETQ APTR (ADD1 APTR])

(CLMAILHEADSTRING
  [LAMBDA (HEAD#)                                        (* jrb%: "31-Mar-86 21:19")

         (* * If the index is outside the array, return a null string to blank out that 
       slot in the menu)

         (* * If the array element is a number, it hasn't been fetched from the hashfile 
       yet; do so)

         (* * Otherwise just return it)

    (COND
       ((GREATERP HEAD# (ARRAYSIZE CLM.HEADARRAY))
        "")
       ((NUMBERP (ELT CLM.HEADARRAY HEAD#))
        (SETA CLM.HEADARRAY HEAD# (CONS (ELT CLM.HEADARRAY HEAD#)
                                        (GETHASHFILE (ELT CLM.HEADARRAY HEAD#)
                                               CLM.HEADHASH)))
        (CDR (ELT CLM.HEADARRAY HEAD#)))
       (T (CDR (ELT CLM.HEADARRAY HEAD#])

(CLMAILFIRST
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 19:50")
    (SETQ CLM.HEAD# 1)
    (CLMAILREDOMENU])

(CLMAILLAST
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 21:58")
    (SETQ CLM.HEAD# (MAX 1 (IDIFFERENCE (ARRAYSIZE CLM.HEADARRAY)
                                  9)))
    (CLMAILREDOMENU])

(CLMAILFWD
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 22:05")
    [SETQ CLM.HEAD# (MAX 1 (MIN (IPLUS CLM.HEAD# 10)
                                (IDIFFERENCE (ARRAYSIZE CLM.HEADARRAY)
                                       9]
    (CLMAILREDOMENU])

(CLMAILBKWD
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 22:05")
    (SETQ CLM.HEAD# (MAX 1 (IDIFFERENCE CLM.HEAD# 10)))
    (CLMAILREDOMENU])

(CLMAILQUIT
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 19:52")
    (CLOSEHASHFILE CLM.MSGHASH)
    (CLOSEHASHFILE CLM.HEADHASH)
    (CLOSEW CLM.MENUWINDOW])

(MAKECMLHEADHASH
  [LAMBDA (DATAFILENAME HASHFILENAME)                    (* jrb%: "26-Mar-86 10:19")
    (LET ((HF (CREATEHASHFILE HASHFILENAME 'SMALLEXPR 70 4100))
          (DF (OPENSTREAM DATAFILENAME 'INPUT))
          KEY SUBJECT SENDER DATE)
         (while (NOT (EOFP DF)) do (SETQ KEY (READ DF))
                                          (SETQ SUBJECT (READ DF))
                                          (SETQ SENDER (READ DF))
                                          (SETQ DATE (READ DF))
                                          (PUTHASHFILE KEY (CONCAT SUBJECT " " SENDER " " DATE)
                                                 HF) finally (CLOSEHASHFILE HF)
                                                           (CLOSEF DF])

(MAKECMLMAILHASH
  [LAMBDA (DATAFILENAME HASHFILENAME)                    (* jrb%: "29-Oct-86 12:43")
    (LET ((HF (CREATEHASHFILE HASHFILENAME 'EXPR 80 23000))
          (DF (OPENSTREAM DATAFILENAME 'INPUT))
          KEY VLIST NEXTITEM)
         (SETQ KEY (READ DF))
         (CL:UNWIND-PROTECT
             (while (NOT (EOFP DF)) do (if (NUMBERP (SETQ NEXTITEM (READ DF)))
                                                   then (push VLIST NEXTITEM)
                                                 else (PUTHASHFILE KEY (CL:NREVERSE VLIST)
                                                                 HF)
                                                       (SETQ KEY NEXTITEM)
                                                       (SETQ VLIST NIL))
                finally (PUTHASHFILE KEY (CL:NREVERSE VLIST)
                                   HF))
             (CLOSEHASHFILE HF)
             (CLOSEF DF))])

(UPDATEHASHFILES
  [LAMBDA NIL                                            (* jrb%: "28-May-86 13:32")

         (* * First open all the files)

    (LET [(MDF (OPENSTREAM CLM.MAILDATANAME 'INPUT))
          (HDF (OPENSTREAM CLM.HEADDATANAME 'INPUT))
          (MHF (OPENHASHFILE CLM.MAILHASHNAME 'BOTH))
          (HHF (OPENHASHFILE CLM.HEADHASHNAME 'BOTH]

         (* * Then hash out all the new header lines)

         (while (READP HDF) bind KEY SUBJECT VAXCFILE do (SETQ KEY (READ HDF))
                                                                    (SETQ SUBJECT (READ HDF))
                                                                    (PUTHASHFILE KEY SUBJECT HHF)
                                                                    (COPYFILE (SETQ VAXCFILE
                                                                               (CONCAT CLM.VAXCDIR 
                                                                                      KEY))
                                                                           (CONCAT CLM.MSGDIR KEY))
                                                                    (DELFILE VAXCFILE)
                                                                    (PRINTOUT T KEY %,)
            finally (CLOSEHASHFILE HHF)
                  (CLOSEF HDF)
                  (TERPRI))

         (* * And then update the message hash file)

         (while (READP MDF) bind (KEY _ (READ MDF))
                                      NEXTITEM VLIST
            do (if (NUMBERP (SETQ NEXTITEM (READ MDF)))
                       then (push VLIST NEXTITEM)
                     else (PUTHASHFILE KEY (NCONC (GETHASHFILE KEY MHF)
                                                      (DREVERSE VLIST))
                                     MHF)
                           (PRINTOUT T KEY %,)
                           (SETQ KEY NEXTITEM)
                           (SETQ VLIST NIL)) finally (PUTHASHFILE KEY (NCONC (GETHASHFILE KEY MHF
                                                                                        )
                                                                                 (DREVERSE VLIST))
                                                                MHF)
                                                   (CLOSEF MDF)
                                                   (CLOSEHASHFILE MHF)
                                                   (PRINTOUT T T "DONE!" T])

(CMLMAIL1
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 21:47")
    (CLMAILDISPLAY 1])

(CMLMAIL2
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 21:47")
    (CLMAILDISPLAY 2])

(CMLMAIL3
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 21:50")
    (CLMAILDISPLAY 3])

(CMLMAIL4
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 21:50")
    (CLMAILDISPLAY 4])

(CMLMAIL5
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 21:50")
    (CLMAILDISPLAY 5])

(CMLMAIL6
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 21:50")
    (CLMAILDISPLAY 6])

(CMLMAIL7
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 21:50")
    (CLMAILDISPLAY 7])

(CMLMAIL8
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 21:52")
    (CLMAILDISPLAY 8])

(CMLMAIL9
  [LAMBDA NIL                                            (* jrb%: "31-Mar-86 21:52")
    (CLMAILDISPLAY 9])

(CMLMAIL0
  [LAMBDA NIL                                            (* jrb%: " 1-Apr-86 09:35")
    (CLMAILDISPLAY 0])
)

(RPAQQ CLM.MENUFORMAT
       ((PROPS FORMAT ROW)
        ((TYPE DISPLAY LABEL "Common Lisp Mailing List Index" FONT (MODERN 10 BOLD)
               HJUSTIFY CENTER))
        ((TYPE EDITSTART LABEL "Word (implicit AND):" LINKS (EDIT THEWORD)
               FONT
               (MODERN 10 BOLD))
         (TYPE EDIT ID THEWORD LABEL ""))
        ((TYPE DISPLAY LABEL "Above:" FONT (MODERN 10 BOLD))
         (TYPE DISPLAY ID ABOVEFIELD LABEL "        ")
         (TYPE DISPLAY LABEL "Below:" FONT (MODERN 10 BOLD))
         (TYPE DISPLAY ID BELOWFIELD LABEL "        "))
        ((TYPE MOMENTARY LABEL "Search!" FONT (MODERN 10 BOLD)
               SELECTEDFN CLMAILSEARCH)
         (TYPE MOMENTARY LABEL "First!" FONT (MODERN 10 BOLD)
               SELECTEDFN CLMAILFIRST)
         (TYPE MOMENTARY LABEL "Last!" FONT (MODERN 10 BOLD)
               SELECTEDFN CLMAILLAST)
         (TYPE MOMENTARY LABEL "Forwards!" FONT (MODERN 10 BOLD)
               SELECTEDFN CLMAILFWD)
         (TYPE MOMENTARY LABEL "Backwards!" FONT (MODERN 10 BOLD)
               SELECTEDFN CLMAILBKWD)
         (TYPE MOMENTARY LABEL "Quit!" FONT (MODERN 10 BOLD)
               SELECTEDFN CLMAILQUIT))
        ((TYPE MOMENTARY LABEL 
               "                                                                                " ID
               LINE1 SELECTEDFN CMLMAIL0))
        ((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL1))
        ((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL2))
        ((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL3))
        ((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL4))
        ((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL5))
        ((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL6))
        ((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL7))
        ((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL8))
        ((TYPE MOMENTARY LABEL "" SELECTEDFN CMLMAIL9))))

(RPAQQ CLM.MAILHASHNAME {ERIS}<COMMONLISP>CLMAIL>MSGHASH)

(RPAQQ CLM.HEADHASHNAME {ERIS}<COMMONLISP>CLMAIL>HEADHASH)

(RPAQQ CLM.MAILDATANAME {VAXC}/user/xais/bane/clmail/newwords)

(RPAQQ CLM.HEADDATANAME {VAXC}/user/xais/bane/clmail/newheads)

(RPAQQ CLM.VAXCDIR {VAXC}/user/xais/bane/clmail/)

(RPAQQ CLM.MSGDIR {ERIS}<COMMONLISP>CLMAIL>)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS CLM.HEADITEMS CLM.ABOVEITEM CLM.BELOWITEM CLM.WORD CLM.MSGHASH CLM.HEADHASH 
       CLM.MENUWINDOW CLM.HEADARRAY CLM.HEAD#)
)
(PUTPROPS CLMAIL COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2142 14793 (CLMAILSHOW 2152 . 3870) (CLMAILDISPLAY 3872 . 4146) (CLMAILDISPLAYMSG 4148
 . 4407) (CLMAILSEARCH 4409 . 5038) (CLMAILMSGHASH 5040 . 5280) (CLMAILMERGE 5282 . 6419) (
CLMAILREDOMENU 6421 . 7262) (CLMAILHEADSTRING 7264 . 8073) (CLMAILFIRST 8075 . 8233) (CLMAILLAST 8235
 . 8474) (CLMAILFWD 8476 . 8775) (CLMAILBKWD 8777 . 8967) (CLMAILQUIT 8969 . 9171) (MAKECMLHEADHASH 
9173 . 9946) (MAKECMLMAILHASH 9948 . 10911) (UPDATEHASHFILES 10913 . 13441) (CMLMAIL1 13443 . 13576) (
CMLMAIL2 13578 . 13711) (CMLMAIL3 13713 . 13846) (CMLMAIL4 13848 . 13981) (CMLMAIL5 13983 . 14116) (
CMLMAIL6 14118 . 14251) (CMLMAIL7 14253 . 14386) (CMLMAIL8 14388 . 14521) (CMLMAIL9 14523 . 14656) (
CMLMAIL0 14658 . 14791)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/CLMAIL.dfasl b/internal/library/OBSOLETE/CLMAIL.dfasl
new file mode 100644
index 00000000..516c800a
Binary files /dev/null and b/internal/library/OBSOLETE/CLMAIL.dfasl differ
diff --git a/internal/library/OBSOLETE/CMLHELP b/internal/library/OBSOLETE/CMLHELP
new file mode 100644
index 00000000..cd2790ba
--- /dev/null
+++ b/internal/library/OBSOLETE/CMLHELP
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
(IL:FILECREATED "15-Jun-90 11:50:26" IL:|{DSK}<usr>local>lde>lispcore>internal>library>CMLHELP.;2| 12901  

      IL:|changes| IL:|to:|  (IL:VARS IL:CMLHELPCOMS)

      IL:|previous| IL:|date:| "20-Oct-86 11:42:05" 
IL:|{DSK}<usr>local>lde>lispcore>internal>library>CMLHELP.;1|)


; Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation.  All rights reserved.

(IL:PRETTYCOMPRINT IL:CMLHELPCOMS)

(IL:RPAQQ IL:CMLHELPCOMS ((IL:INITVARS (IL:CMLPATH '(IL:|{ERIS}<CommonLoops>PCL>| 
                                                               IL:{ERIS}<COMMONLISP>CODE> 
                                                               IL:{ERIS}<COMMONLISP>CLC>))
                                     (IL:CMLWINDOW))
                              (IL:FNS IL:ADDHASHFILE IL:CMLSHOW IL:MAKECMLINDEX IL:CMLWINDOW 
                                     IL:CMLHASHFILE)
                              (IL:INITVARS (IL:CMLDEFS)
                                     (IL:CMLMANHASH))))

(IL:RPAQ? IL:CMLPATH '(IL:|{ERIS}<CommonLoops>PCL>| IL:{ERIS}<COMMONLISP>CODE> 
                                 IL:{ERIS}<COMMONLISP>CLC>))

(IL:RPAQ? IL:CMLWINDOW )
(IL:DEFINEQ

(il:addhashfile
  (il:lambda (il:name il:val il:harray)
    (il:puthashfile il:name (cons il:val (il:gethashfile il:name il:harray))
           il:harray)))

(il:cmlshow
  (il:lambda (il:name il:to il:manp)                         (il:* il:|lmm| " 9-May-86 17:13")
    (let
     ((il:out (or il:to (il:|if| il:manp il:|then| (il:setq il:to t)
                               il:|else|
                               (il:openstream 'il:{scratch} 'il:both 'il:new))))
      il:window
      (il:found 0)
      il:str)
     (il:|for|
      il:hf il:|inside| (il:cmlhashfile il:manp)
      il:|do|
      (let
       ((il:lst (il:gethashfile (il:u-case il:name)
                       (car il:hf))))
       (il:|for|
        il:|occurence| il:|inside| (remove-duplicates il:lst :test 'il:equal)
        il:|do|
        (il:resetlst (il:resetsave nil (list 'il:closef? (il:setq il:str
                                                          (il:|for| il:file il:|inside| (cdr il:hf)
                                                                 il:|bind| il:fn il:|when|
                                                                 (il:setq il:fn
                                                                  (il:infilep (il:packfilename
                                                                               'il:body
                                                                               (car il:|occurence|)
                                                                               'il:body il:file)))
                                                                 il:|do|
                                                                 (return (il:openstream il:fn
                                                                                'il:input
                                                                                'il:old))))))
               (il:|if| il:str il:|then|                     (il:* il:|we| il:|found| il:|the| 
                                                             il:|file| il:|on| il:|this| il:|dir|)
                      (let ((il:end (or (il:filepos (il:|if| il:manp il:|then| 
                                                             (il:* il:|end| il:|of| il:|definition|)
                                                           "
@ENDDEF" il:|else|                                           (il:* il:|dunno| il:|where| il:|it| 
                                                             il:|ends,| il:|just| il:|get| il:|the| 
                                                             il:|next| il:|one|)
                                                           "
(def")
                                               il:str
                                               (il:plus 4 (cadr il:|occurence|))
                                               nil nil nil (il:uppercasearray))
                                        (il:geteofptr il:str))))
                           (il:selectq il:out
                                 (il:tedit (il:opentextstream il:str (il:|if| il:window il:|then|
                                                                            (il:createw nil 
                                                                                   "CML definitions")
                                                                            il:|else|
                                                                            (il:setq il:window (
                                                                                         il:cmlwindow
                                                                                                )))
                                                  (cadr il:|occurence|)
                                                  il:end
                                                  (and (not il:manp)
                                                       '(il:font (il:terminal 10)
                                                               il:paralooks
                                                               (il:tabs (48))))))
                                 ((il:allfile t) 
                                       (il:setq il:window (il:|if| il:window il:|then|
                                                                 (il:createw nil "CML definitions")
                                                                 il:|else|
                                                                 (il:cmlwindow)))
                                       (il:windowprop il:window 'il:title (il:fullname il:str))
                                       (il:tedit.setsel (il:setq il:str
                                                         (il:opentextstream
                                                          il:str nil nil nil
                                                          (and (not il:manp)
                                                               '(il:font (il:terminal 10)
                                                                       il:paralooks
                                                                       (il:tabs (48))))))
                                              (cadr il:|occurence|)
                                              (il:difference il:end (cadr il:|occurence|)))
                                       (il:opentextstream il:str il:window nil nil
                                              (and (not il:manp)
                                                   '(il:font (il:terminal 10)
                                                           il:paralooks
                                                           (il:tabs (48))))))
                                 (progn (il:printout il:out "(from " (il:fullname il:str)
                                               ")" t)
                                        (il:copybytes il:str il:out (cadr il:|occurence|)
                                               il:end)
                                        (il:terpri il:out)))
                           (il:|add| il:found 1)))))))
     (il:|if| (not il:to)
            il:|then|
            (il:opentextstream il:out (let ((il:w (il:cmlwindow)))
                                           (il:windowprop il:w 'il:title "Common Lisp definition")
                                           il:w)
                   nil nil '(il:font (il:terminal 10)
                                   il:paralooks
                                   (il:tabs (48))))
            (let ((il:pw (il:getpromptwindow (il:cmlwindow))))
                 (il:clearw il:pw)
                 (il:selectq il:found
                       (0 (il:printout il:pw "No occurences of" il:\, il:name "."))
                       (1 (il:printout il:pw il:found il:\, "occurence of" il:\, il:name "."))
                       (il:printout il:pw il:found il:\, "occurences of" il:\, il:name "."))))
     il:found)))

(il:makecmlindex
  (il:lambda (il:pattern il:hf il:manp)                      (il:* il:|lmm| "28-Apr-86 11:44")
    (il:setq il:hf (il:openhashfile (or il:hf "CML.HASH")
                          'il:new 40 3080))
    (il:|bind| il:str il:nf (il:readtable il:_ (il:|if| il:manp il:|then|
                                                      (let ((il:rt (il:copyreadtable il:cmlrdtbl)))
                                                           (il:setsyntax (il:charcode ",")
                                                                  'il:sepr il:rt)
                                                           (il:setsyntax (il:charcode il:})
                                                                  'il:sepr il:rt)
                                                           (il:setsyntax (il:charcode il:{)
                                                                  'il:sepr il:rt)
                                                           il:rt)
                                                      il:|else| il:cmlrdtbl))
           il:|for| il:file il:|in| (il:fildir (il:packfilename 'il:body il:pattern 'il:extension
                                                      'il:*
                                                      'il:version "" 'il:name 'il:*))
           il:|do|
           (il:resetlst (il:resetsave nil (list 'il:closef? (il:setq il:str (il:openstream
                                                                             il:file
                                                                             'il:input
                                                                             'il:old))))
                  (il:setq il:nf (il:namefield il:file t))
                  (il:printout t il:file t)
                  (il:|while| (il:filepos (il:|if| il:manp il:|then| "
@Def" il:|else| "
(def")
                                     il:str nil nil nil nil (il:uppercasearray))
                         il:|do|
                         (il:readc il:str)
                         (let ((il:pos (il:getfileptr il:str))
                               (il:deffer (progn (il:bin il:str)
                                                 (il:read il:str il:readtable)))
                               (il:defd (il:read il:str il:readtable)))
                              (il:printout t ".")
                              (let ((il:defa (il:|if| (il:listp il:defd)
                                                    il:|then|
                                                    (il:|if| il:manp il:|then| (cadr il:defd)
                                                           il:|else|
                                                           (car il:defd))
                                                    il:|else| il:defd)))
                                   (il:|if| (symbolp il:defa)
                                          il:|then|
                                          (il:addhashfile il:defa (list il:nf il:pos)
                                                 il:hf)))))))))

(il:cmlwindow
  (il:lambda nil
    (or il:cmlwindow (il:setq il:cmlwindow (il:createw '(0 0 500 300) "CML definitions")))))

(il:cmlhashfile
  (il:lambda (il:manp)                                       (il:* il:|lmm| "28-Apr-86 11:59")
    (il:|if| il:manp il:|then| (or il:cmlmanhash (il:setq il:cmlmanhash
                                                  (list (cons (il:openhashfile '
                                                                 il:{eris}<commonlisp>manual>cml.hash
                                                                     'il:input)
                                                              'il:{eris}<commonlisp>manual>))))
           il:|else|
           (or il:cmldefs (il:setq il:cmldefs (il:|for| il:|path| il:|inside| il:cmlpath il:|bind| 
                                                     il:file il:|when| (il:setq il:file
                                                                        (il:findfile "CML.HASH" t
                                                                               (il:mklist il:|path|))
                                                                        )
                                                     il:|collect|
                                                     (cons (il:openhashfile il:file 'il:input)
                                                           il:|path|)))))))
)

(IL:RPAQ? IL:CMLDEFS )

(IL:RPAQ? IL:CMLMANHASH )
(IL:PUTPROPS IL:CMLHELP IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990))
(IL:DECLARE\: IL:DONTCOPY
  (IL:FILEMAP (NIL (1218 12730 (IL:ADDHASHFILE 1231 . 1391) (IL:CMLSHOW 1393 . 8243) (IL:MAKECMLINDEX 
8245 . 11324) (IL:CMLWINDOW 11326 . 11453) (IL:CMLHASHFILE 11455 . 12728)))))
IL:STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/COLOR b/internal/library/OBSOLETE/COLOR
new file mode 100644
index 00000000..f5b66bed
--- /dev/null
+++ b/internal/library/OBSOLETE/COLOR
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "15-Jun-90 12:08:41" {DSK}<usr>local>lde>lispcore>internal>library>COLOR.;2 61676  

      changes to%:  (VARS COLORCOMS)

      previous date%: "27-Jan-87 15:56:46" {DSK}<usr>local>lde>lispcore>internal>library>COLOR.;1)


(* ; "
Copyright (c) 1982, 1983, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT COLORCOMS)

(RPAQQ COLORCOMS
       [(FNS DISPLAYCOLORLEVELS DISPLAYHLSLEVELS HLSLEVEL HLSTORGB HLSVALUEFN HLSVALUEFROMLEVEL 
             LEVELFROMHLSVALUE RAINBOWMAP RGBTOHLS)
        (FNS OVERPAINT BITMAPFROMSTRING SHADEBITMAP)
        (INITVARS (EDITCOLORMAP.WINDOW NIL))
        (FNS EDITCOLORMAP EDITCOLORMAP.BUTTONEVENTFN EDITCOLORMAP.REDISPLAYFN EDITCOLORMAP.VALUELEVEL
             EDITCOLORMAP.WINDOWLEVEL CHANGECOLORLEVELS GETCOLOR#FROMUSER GETCOLOR#FROMSCREEN 
             DISPLAYCOLORLEVEL FILLINREGION AREAFILL CENTEREDLEFT OUTLINEAREA OUTLINEREGION)
        (FNS ADJUSTCOLORMAP SHOWCOLORBLOCKS MAPOFACOLOR COLORHEXPATTERN)
        (VARS EditColorMapHeight EditColorMapWidth (COLOR#MENUSAVE)
              (CONTROLMENUSAVE)
              (EDIT8BITCOLORMAPMENU)
              (EDIT8BITCOLORMAPNUMBERREADER))
        (GLOBALVARS COLOR#MENUSAVE CONTROLMENUSAVE EDIT8BITCOLORMAPMENU EDIT8BITCOLORMAPNUMBERREADER
               EditColorMapHeight EditColorMapWidth)
        (COMS 

(* ;;; "support for global naming and querying of colors.")

              (FNS CNSMENUINIT CNSTOCSL CNSTORGB CSLTOCNS DICOLOR.FROM.USER GETCNS HLSTOCSL CSLTOHLS
                   RGBTOCNS)
              (VARS DICOLOR.hueMapping DICOLOR.lightnessMapping DICOLOR.saturationMapping 
                    NEWCOLORITEM)
              (INITVARS (COLORNAMEMENU))
              (FNS DICOLOR.hueN DICOLOR.hueNvalue DICOLOR.hueNname DICOLOR.lightnessN 
                   DICOLOR.lightnessNvalue DICOLOR.lightnessNname DICOLOR.saturationN 
                   DICOLOR.saturationNvalue DICOLOR.saturationNname)
              (DECLARE%: EVAL@LOAD DONTCOPY (*)
                     (RECORDS hueRecord lightnessRecord saturationRecord)
                     (CONSTANTS * DICOLOR.hueConstants)
                     (CONSTANTS * DICOLOR.saturationConstants)
                     (CONSTANTS * DICOLOR.lightnessConstants))
              (P (CNSMENUINIT)))
        (FILES LLCOLOR READNUMBER)
        (P (SETQ EDITBMMENU NIL)
           (MOVD 'ARRAYP 'COLORMAPP])
(DEFINEQ

(DISPLAYCOLORLEVELS
  [LAMBDA (WINDOW RGB)                                       (* kbr%: " 3-Jun-86 19:45")
    (PROG (HLS)
          (DISPLAYCOLORLEVEL WINDOW 'RED (fetch (RGB RED) of RGB)
                 (fetch (RGB RED) of RGB))
          (DISPLAYCOLORLEVEL WINDOW 'GREEN (fetch (RGB GREEN) of RGB)
                 (fetch (RGB GREEN) of RGB))
          (DISPLAYCOLORLEVEL WINDOW 'BLUE (fetch (RGB BLUE) of RGB)
                 (fetch (RGB BLUE) of RGB))
          (SETQ HLS (RGBTOHLS RGB))
          (DISPLAYCOLORLEVEL WINDOW 'HUE (fetch (HLS HUE) of HLS)
                 (EDITCOLORMAP.WINDOWLEVEL 'HUE (fetch (HLS HUE) of HLS)))
          (DISPLAYCOLORLEVEL WINDOW 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS)
                 (EDITCOLORMAP.WINDOWLEVEL 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS)))
          (DISPLAYCOLORLEVEL WINDOW 'SATURATION (fetch (HLS SATURATION) of HLS)
                 (EDITCOLORMAP.WINDOWLEVEL 'SATURATION (fetch (HLS SATURATION) of HLS])

(DISPLAYHLSLEVELS
  [LAMBDA (HLS WIN)                                          (* rrb "25-OCT-82 14:08")
          
          (* displays a hue lightness saturation triple in the edit window.)

    (DISPLAYHLSLEVEL HLS 'HUE NIL WIN)
    (DISPLAYHLSLEVEL HLS 'LIGHTNESS NIL WIN)
    (DISPLAYHLSLEVEL HLS 'SATURATION NIL WIN])

(HLSLEVEL
  [LAMBDA (HLS FIELD NEWLEVEL)                               (* rrb "25-OCT-82 13:29")
          
          (* returns the value of the named field from a hue lightness saturation record.)

    (SELECTQ FIELD
        (HUE (PROG1 (fetch (HLS HUE) of HLS)
                    (AND NEWLEVEL (replace (HLS HUE) of HLS with NEWLEVEL))))
        (LIGHTNESS (PROG1 (fetch (HLS LIGHTNESS) of HLS)
                          (AND NEWLEVEL (replace (HLS LIGHTNESS) of HLS with NEWLEVEL))))
        (SATURATION (PROG1 (fetch (HLS SATURATION) of HLS)
                           (AND NEWLEVEL (replace (HLS SATURATION) of HLS with NEWLEVEL))))
        (SHOULDNT])

(HLSTORGB
  [LAMBDA (HLS LIGHTNESS SATURATION)                         (* kbr%: " 3-Jun-86 21:16")
          
          (* 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 (HUE M1 M2 RGB)
          (COND
             ((LISTP HLS)
              (SETQ HUE (fetch (HLS HUE) of HLS))
              (SETQ LIGHTNESS (fetch (HLS LIGHTNESS) of HLS))
              (SETQ SATURATION (fetch (HLS SATURATION) of HLS)))
             (T (SETQ HUE HLS)))
          [SETQ M1 (COND
                      ((FGREATERP 0.5 LIGHTNESS)
                       (FTIMES LIGHTNESS (FPLUS 1.0 SATURATION)))
                      (T (FDIFFERENCE (FPLUS LIGHTNESS SATURATION)
                                (FTIMES LIGHTNESS SATURATION]
          (SETQ M2 (FDIFFERENCE (FTIMES 2.0 LIGHTNESS)
                          M1))
          [SETQ RGB (create RGB
                           RED _ (HLSVALUEFN M1 M2 HUE)
                           GREEN _ (HLSVALUEFN M1 M2 (IDIFFERENCE HUE 120))
                           BLUE _ (HLSVALUEFN M1 M2 (IDIFFERENCE HUE 240]
          (RETURN RGB])

(HLSVALUEFN
  [LAMBDA (M1 M2 HUE)                                        (* kbr%: " 3-Jun-86 20:45")
          
          (* Internal value function for converting from HLS to RGB.
          *)

    (SETQ HUE (IMOD HUE 360))
    (FIX (FTIMES (COND
                    ((ILESSP HUE 60)
                     M1)
                    [(ILESSP HUE 120)
                     (FPLUS M1 (FTIMES (FQUOTIENT (FDIFFERENCE HUE 60)
                                              60)
                                      (FDIFFERENCE M2 M1]
                    ((ILESSP HUE 240)
                     M2)
                    [(ILESSP HUE 300)
                     (FPLUS M2 (FTIMES (FQUOTIENT (FDIFFERENCE HUE 240)
                                              60)
                                      (FDIFFERENCE M1 M2]
                    (T M1))
                255])

(HLSVALUEFROMLEVEL
  [LAMBDA (HLS LEVEL)                                        (* rrb "25-OCT-82 13:26")
          
          (* returns the scaled value of the hls marker on a scale from 0 to 255)

    (SELECTQ HLS
        (HUE (IQUOTIENT (ITIMES LEVEL 360)
                    255))
        (FQUOTIENT LEVEL 255])

(LEVELFROMHLSVALUE
  [LAMBDA (HLS LEVEL)                                        (* rrb "25-OCT-82 14:06")
          
          (* returns the level on a scale from 0 to 255 that this value would have.)

    (SELECTQ HLS
        (HUE (IQUOTIENT (ITIMES LEVEL 255)
                    360))
        (FIX (FTIMES LEVEL 255])

(RAINBOWMAP
  [LAMBDA (NBITS)                                            (* rrb "21-OCT-82 18:14")
    [OR NBITS (NULL (COLORDISPLAYP))
        (SETQ NBITS (COLORMAPBITS (SCREENCOLORMAP]
    (COLORMAPCREATE (COND
                       [(EQ NBITS 8)
                        (PROG (MAXINTENSITY MINVISIBLERED MINVISIBLEBLUE MINVISIBLEGREEN NSTEPS 
                                     REDSTEPSIZE GREENSTEPSIZE BLUESTEPSIZE)
                              (SETQ MAXINTENSITY 255)
                              (SETQ MINVISIBLERED 69)
                              (SETQ MINVISIBLEBLUE 38)
                              (SETQ MINVISIBLEGREEN 38)
                              (SETQ NSTEPS (IQUOTIENT (EXPT 2 NBITS)
                                                  8))
          
          (* determine how many steps are available for each transition from one color to 
          the next. There are 8 such transitions. red up, green up, red down, blue up, 
          green down, red up, green up, all down)
          
          (* minimum visible intensity values were emperically determined but will differ 
          depending upon the brightness setting of the individual display.
          They are also diddled to make the numer of steps come out right.)

                              (RETURN (NCONC (for I from MINVISIBLERED to MAXINTENSITY
                                                by (SETQ REDSTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE
                                                                                        MAXINTENSITY 
                                                                                        MINVISIBLERED
                                                                                        )
                                                                                       NSTEPS -2)
                                                                            NSTEPS))
                                                collect      (* red up)
                                                      (LIST I 0 0))
                                             (for I from MINVISIBLEGREEN to MAXINTENSITY
                                                by (SETQ GREENSTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE
                                                                                          
                                                                                         MAXINTENSITY 
                                                                                      MINVISIBLEGREEN
                                                                                          )
                                                                                         -1 NSTEPS)
                                                                              NSTEPS))
                                                collect      (* GREEN UP)
                                                      (LIST 255 I 0))
                                             (for I from REDSTEPSIZE to (IDIFFERENCE MAXINTENSITY 
                                                                               MINVISIBLERED)
                                                by REDSTEPSIZE collect 
                                                             (* red down)
                                                                     (LIST (IDIFFERENCE MAXINTENSITY 
                                                                                  I)
                                                                           255 0))
                                             (CONS '(0 255 0))
                                             (for I from MINVISIBLEBLUE to MAXINTENSITY
                                                by (SETQ BLUESTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE
                                                                                         MAXINTENSITY 
                                                                                       MINVISIBLEBLUE
                                                                                         )
                                                                                        -1 NSTEPS)
                                                                             NSTEPS))
                                                collect      (* BLUE UP)
                                                      (LIST 0 255 I))
                                             (for I from GREENSTEPSIZE to (IDIFFERENCE MAXINTENSITY 
                                                                                 MINVISIBLEGREEN)
                                                by GREENSTEPSIZE collect 
                                                             (* GREEN down)
                                                                       (LIST 0 (IDIFFERENCE 
                                                                                      MAXINTENSITY I)
                                                                             255))
                                             (CONS '(0 0 255))
                                             (for I from MINVISIBLERED to MAXINTENSITY by REDSTEPSIZE
                                                collect      (* red up)
                                                      (LIST I 0 255))
                                             (for I from MINVISIBLEGREEN to MAXINTENSITY by 
                                                                                        GREENSTEPSIZE
                                                collect      (* GREEN UP)
                                                      (LIST 255 I 255))
                                             (for I from GREENSTEPSIZE to (IDIFFERENCE MAXINTENSITY 
                                                                                 MINVISIBLEGREEN)
                                                by GREENSTEPSIZE collect 
                                                             (* all down)
                                                                       (LIST (IDIFFERENCE 
                                                                                    MAXINTENSITY I)
                                                                             (IDIFFERENCE 
                                                                                    MAXINTENSITY I)
                                                                             (IDIFFERENCE 
                                                                                    MAXINTENSITY I)))
                                             (CONS '(0 0 0]
                       (T RAINBOWINTENSITIES))
           NBITS])

(RGBTOHLS
  [LAMBDA (RGB GREEN BLUE)                                   (* kbr%: " 3-Jun-86 20:13")
          
          (* Converts from a red green blue triple of color information into a hue 
          lightness saturation triple. *)
          
          (* This algorithm was taken from Procedural Elements for Computer Graphics 1985 
          page 405 by David F. Rogers *)

    (PROG (RED CR CG CB M1 M2 LIGHTNESS HLS)
          (COND
             ((LISTP RGB)
              (SETQ RED (fetch (RGB RED) of RGB))
              (SETQ GREEN (fetch (RGB GREEN) of RGB))
              (SETQ BLUE (fetch (RGB BLUE) of RGB)))
             (T (SETQ RED RGB)))
          (SETQ M1 (MAX RED GREEN BLUE))
          (SETQ M2 (MIN RED GREEN BLUE))
          (SETQ LIGHTNESS (FQUOTIENT (FPLUS (FQUOTIENT M1 255)
                                            (FQUOTIENT M2 255))
                                 2))
          [SETQ HLS (COND
                       ((EQ M1 M2)
                        (create HLS
                               HUE _ 0
                               LIGHTNESS _ LIGHTNESS
                               SATURATION _ 0.0))
                       (T (SETQ CR (FQUOTIENT (IDIFFERENCE M1 RED)
                                          (IDIFFERENCE M1 M2)))
                          (SETQ CG (FQUOTIENT (IDIFFERENCE M1 GREEN)
                                          (IDIFFERENCE M1 M2)))
                          (SETQ CB (FQUOTIENT (IDIFFERENCE M1 BLUE)
                                          (IDIFFERENCE M1 M2)))
                          (create HLS
                                 HUE _ (IMOD (FIX (FTIMES [COND
                                                             ((EQ M1 RED)
                                                              (FDIFFERENCE CB CG))
                                                             ((EQ M1 GREEN)
                                                              (FPLUS 2.0 (FDIFFERENCE CR CB)))
                                                             (T (FPLUS 4.0 (FDIFFERENCE CG CR]
                                                         60.0))
                                             360)
                                 LIGHTNESS _ LIGHTNESS
                                 SATURATION _ (COND
                                                 ((FGREATERP 0.5 LIGHTNESS)
                                                  (FQUOTIENT (IDIFFERENCE M1 M2)
                                                         (IPLUS M1 M2)))
                                                 (T (FQUOTIENT (IDIFFERENCE M1 M2)
                                                           (IDIFFERENCE (ITIMES 2 255)
                                                                  (IPLUS M1 M2]
          (RETURN HLS])
)
(DEFINEQ

(OVERPAINT
  [LAMBDA (BM1 BM2 X Y TXT SCR)                              (* kbr%: " 2-Sep-85 20:30")
          
          (* Uses BM1 as a mask thru which it paints the INVERSE of texture onto BM2 at 
          position X Y)

    (PROG (BMW BMH)
          (SETQ BMW (BITMAPWIDTH BM1))
          (SETQ BMH (BITMAPHEIGHT BM1))
          (OR SCR (SETQ SCR (BITMAPCOPY BM1)))               (* We need a scratch BM.
                                                             Most demos cache one)
          (BITBLT BM1 0 0 SCR 0 0 BMW BMH 'INPUT 'REPLACE)
          (BITBLT NIL NIL NIL SCR 0 0 BMW BMH 'TEXTURE 'ERASE TXT)
          (BITBLT BM1 0 0 BM2 X Y BMW BMH 'INPUT 'ERASE)
          (BITBLT SCR 0 0 BM2 X Y BMW BMH 'INPUT 'PAINT])

(BITMAPFROMSTRING
  [LAMBDA (STRING FONT BITSPERPIXEL)                         (* kbr%: "11-Aug-85 16:14")
    (PROG (BITMAP DS)
          (SETQ BITMAP (BITMAPCREATE (STRINGWIDTH STRING FONT)
                              (FONTPROP FONT 'HEIGHT)
                              BITSPERPIXEL))
          (SETQ DS (DSPCREATE BITMAP))
          (DSPFONT FONT DS)
          (MOVETO 0 (FONTPROP FONT 'DESCENT)
                 DS)
          (PRIN3 STRING DS)
          (RETURN BITMAP])

(SHADEBITMAP
  [LAMBDA (BM T0 T1)                                         (* bas%: "25-APR-82 15:02")
          
          (* Shades bitmap BM with T0 into 0 areas and T1 into 1 areas)

    (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'INVERT (LOGAND T0 (LOGXOR T0 T1)))
    (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'PAINT (LOGAND T0 T1))
    (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'ERASE (LOGXOR (LOGOR T0 T1)
                                                                  65535])
)

(RPAQ? EDITCOLORMAP.WINDOW NIL)
(DEFINEQ

(EDITCOLORMAP
  [LAMBDA NIL                                                (* kbr%: " 5-Jun-86 22:49")
                                                             (* Colormap Editor. Let's user 
                                                             interactively adjust colormap.
                                                             *)
    (PROG (XPOS REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION BOTTOM)
          (COND
             ((NULL EDITCOLORMAP.WINDOW)
              (SETQ EDITCOLORMAP.WINDOW (CREATEW (GETBOXREGION EditColorMapWidth EditColorMapHeight 
                                                        NIL NIL NIL 
                                                        "Select location of Colormap Editor window.")
                                               "Colormap Editor"))
              (CLRPROMPT)
              (WINDOWPROP EDITCOLORMAP.WINDOW 'BUTTONEVENTFN 'EDITCOLORMAP.BUTTONEVENTFN)
              (WINDOWPROP EDITCOLORMAP.WINDOW 'REPAINTFN 'EDITCOLORMAP.REDISPLAYFN)
              (WINDOWPROP EDITCOLORMAP.WINDOW 'COLOR 0))
             (T (CLEARW EDITCOLORMAP.WINDOW)))
          (REDISPLAYW EDITCOLORMAP.WINDOW])

(EDITCOLORMAP.BUTTONEVENTFN
  [LAMBDA (WINDOW)                                           (* kbr%: " 4-Jun-86 21:21")
          
          (* Colormap editor. Displays a colormap in a window and allows the user to 
          change it. *)

    (PROG (REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION BOTTOM COLOR 
                 COLORMAP LEVEL LASTX LASTY HLS OLDLEVEL COMPONENT)
          (PROGN (SETQ REDREGION (WINDOWPROP WINDOW 'REDREGION))
                 (SETQ GREENREGION (WINDOWPROP WINDOW 'GREENREGION))
                 (SETQ BLUEREGION (WINDOWPROP WINDOW 'BLUEREGION))
                 (SETQ HUEREGION (WINDOWPROP WINDOW 'HUEREGION))
                 (SETQ LIGHTNESSREGION (WINDOWPROP WINDOW 'LIGHTNESSREGION))
                 (SETQ SATURATIONREGION (WINDOWPROP WINDOW 'SATURATIONREGION))
                 (SETQ BOTTOM (fetch (REGION BOTTOM) of REDREGION)))
          (SETQ COLOR (WINDOWPROP WINDOW 'COLOR))
          (SETQ COLORMAP (SCREENCOLORMAP))
          (COND
             [(LASTMOUSESTATE MIDDLE)
              (COND
                 ((NUMBERP (SETQ LEVEL (GETCOLOR#FROMUSER)))
                  (WINDOWPROP WINDOW 'COLOR LEVEL)
                  (REDISPLAYW WINDOW]
             ((LASTMOUSESTATE LEFT)
              (SETQ LASTX (LASTMOUSEX WINDOW))
              (SETQ LASTY (LASTMOUSEY WINDOW))
              (COND
                 ([SETQ COMPONENT (COND
                                     ((INSIDEP REDREGION LASTX LASTY)
                                      'RED)
                                     ((INSIDEP GREENREGION LASTX LASTY)
                                      'GREEN)
                                     ((INSIDEP BLUEREGION LASTX LASTY)
                                      'BLUE)
                                     ((INSIDEP HUEREGION LASTX LASTY)
                                      'HUE)
                                     ((INSIDEP LIGHTNESSREGION LASTX LASTY)
                                      'LIGHTNESS)
                                     ((INSIDEP SATURATIONREGION LASTX LASTY)
                                      'SATURATION]
                  (SETQ OLDLEVEL (WINDOWPROP WINDOW COMPONENT))
                  (until (MOUSESTATE (NOT LEFT)) do 
          
          (* As long as LEFT is down, adjust the color.
          *)

                                                    [SETQ LEVEL (IMIN 255 (IMAX 0 (IDIFFERENCE
                                                                                   (LASTMOUSEY WINDOW
                                                                                          )
                                                                                   BOTTOM]
                                                    (COND
                                                       ((NOT (EQ LEVEL OLDLEVEL))
                                                        (CHANGECOLORLEVELS WINDOW COMPONENT LEVEL)
                                                        [SCREENCOLORMAPENTRY
                                                         COLOR
                                                         (create RGB
                                                                RED _ (WINDOWPROP WINDOW 'RED)
                                                                GREEN _ (WINDOWPROP WINDOW
                                                                               'GREEN)
                                                                BLUE _ (WINDOWPROP WINDOW
                                                                              'BLUE]
                                                        (SETQ OLDLEVEL LEVEL])

(EDITCOLORMAP.REDISPLAYFN
  [LAMBDA (WINDOW)                                           (* kbr%: " 4-Jun-86 20:46")
                                                             (* Colormap Editor. Let's user 
                                                             interactively adjust colormap.
                                                             *)
    (PROG (XPOS REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION BOTTOM 
                COLORMAP COLOR)
          (CLEARW WINDOW)
          (PROGN (MOVETO 35 4 WINDOW)
                 (PRIN1 "RED" WINDOW)
                 (SETQ REDREGION '(40 16 10 256))
                 (OUTLINEREGION REDREGION 2 NIL WINDOW)
                 (WINDOWPROP WINDOW 'REDREGION REDREGION))
          (PROGN (MOVETO 70 4 WINDOW)
                 (PRIN1 "GREEN" WINDOW)
                 (SETQ GREENREGION '(82 16 10 256))
                 (OUTLINEREGION GREENREGION 2 NIL WINDOW)
                 (WINDOWPROP WINDOW 'GREENREGION GREENREGION))
          (PROGN (MOVETO 119 4 WINDOW)
                 (PRIN1 "BLUE" WINDOW)
                 (SETQ BLUEREGION '(128 16 10 256))
                 (OUTLINEREGION BLUEREGION 2 NIL WINDOW)
                 (WINDOWPROP WINDOW 'BLUEREGION BLUEREGION))
          (PROGN (MOVETO 181 4 WINDOW)
                 (PRIN1 "HUE" WINDOW)
                 (SETQ HUEREGION '(186 16 10 256))
                 (OUTLINEREGION HUEREGION 2 NIL WINDOW)
                 (WINDOWPROP WINDOW 'HUEREGION HUEREGION))
          (PROGN (MOVETO 216 4 WINDOW)
                 (PRIN1 "LIGHTNESS" WINDOW)
                 (SETQ LIGHTNESSREGION '(242 16 10 256))
                 (OUTLINEREGION LIGHTNESSREGION 2 NIL WINDOW)
                 (WINDOWPROP WINDOW 'LIGHTNESSREGION LIGHTNESSREGION))
          (PROGN (MOVETO 300 4 WINDOW)
                 (PRIN1 "SAT" WINDOW)
                 (SETQ SATURATIONREGION '(305 16 10 256))
                 (OUTLINEREGION SATURATIONREGION 2 NIL WINDOW)
                 (WINDOWPROP WINDOW 'SATURATIONREGION SATURATIONREGION))
          (PROGN (SETQ COLORMAP (SCREENCOLORMAP))
                 (SETQ COLOR (WINDOWPROP WINDOW 'COLOR))
                 (MOVETO 8 250 WINDOW)
                 (printout WINDOW |.I3| COLOR)
                 (DISPLAYCOLORLEVELS WINDOW (ELT COLORMAP COLOR])

(EDITCOLORMAP.VALUELEVEL
  [LAMBDA (COMPONENT WINDOWLEVEL)                            (* kbr%: " 3-Jun-86 19:55")
          
          (* * Value that would be stored in an RGB or HLS corresponding to WINDOWLEVEL.
          *)

    (SELECTQ COMPONENT
        (HUE (IQUOTIENT (ITIMES WINDOWLEVEL 360)
                    255))
        ((LIGHTNESS SATURATION) 
             (FQUOTIENT WINDOWLEVEL 255))
        ((RED GREEN BLUE) 
             WINDOWLEVEL)
        (SHOULDNT])

(EDITCOLORMAP.WINDOWLEVEL
  [LAMBDA (COMPONENT VALUELEVEL)                             (* kbr%: " 3-Jun-86 19:55")
          
          (* * Given VALUELEVEL of an RGB or HLS, what WINDOWLEVEL should be used to 
          display it? *)

    (SELECTQ COMPONENT
        (HUE (IQUOTIENT (ITIMES VALUELEVEL 255)
                    360))
        ((LIGHTNESS SATURATION) 
             (FIX (FTIMES VALUELEVEL 255)))
        ((RED GREEN BLUE) 
             VALUELEVEL)
        (SHOULDNT])

(CHANGECOLORLEVELS
  [LAMBDA (WINDOW COMPONENT WINDOWLEVEL)                     (* kbr%: " 3-Jun-86 19:55")
    (PROG (RGB HLS)
          (DISPLAYCOLORLEVEL WINDOW COMPONENT (EDITCOLORMAP.VALUELEVEL COMPONENT WINDOWLEVEL)
                 WINDOWLEVEL)
          (SELECTQ COMPONENT
              ((RED GREEN BLUE) 
                   [SETQ HLS (RGBTOHLS (WINDOWPROP WINDOW 'RED)
                                    (WINDOWPROP WINDOW 'GREEN)
                                    (WINDOWPROP WINDOW 'BLUE]
                   (DISPLAYCOLORLEVEL WINDOW 'HUE (fetch (HLS HUE) of HLS)
                          (EDITCOLORMAP.WINDOWLEVEL 'HUE (fetch (HLS HUE) of HLS)))
                   (DISPLAYCOLORLEVEL WINDOW 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS)
                          (EDITCOLORMAP.WINDOWLEVEL 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS)))
                   (DISPLAYCOLORLEVEL WINDOW 'SATURATION (fetch (HLS SATURATION) of HLS)
                          (EDITCOLORMAP.WINDOWLEVEL 'SATURATION (fetch (HLS SATURATION) of HLS))))
              ((HUE LIGHTNESS SATURATION) 
                   [SETQ RGB (HLSTORGB (EDITCOLORMAP.VALUELEVEL 'HUE (WINDOWPROP WINDOW 'HUE))
                                    (EDITCOLORMAP.VALUELEVEL 'LIGHTNESS (WINDOWPROP WINDOW
                                                                               'LIGHTNESS))
                                    (EDITCOLORMAP.VALUELEVEL 'SATURATION (WINDOWPROP WINDOW
                                                                                'SATURATION]
                   (DISPLAYCOLORLEVEL WINDOW 'RED (fetch (RGB RED) of RGB)
                          (fetch (RGB RED) of RGB))
                   (DISPLAYCOLORLEVEL WINDOW 'GREEN (fetch (RGB GREEN) of RGB)
                          (fetch (RGB GREEN) of RGB))
                   (DISPLAYCOLORLEVEL WINDOW 'BLUE (fetch (RGB BLUE) of RGB)
                          (fetch (RGB BLUE) of RGB)))
              (SHOULDNT])

(GETCOLOR#FROMUSER
  [LAMBDA NIL                                                (* edited%: " 8-SEP-82 21:44")
                                                             (* reads a color number from the user.)
    (PROG (RESPONSE)
          (MOVEW [COND
                    ((TYPENAMEP EDIT8BITCOLORMAPNUMBERREADER 'WINDOW)
                     EDIT8BITCOLORMAPNUMBERREADER)
                    (T (SETQ EDIT8BITCOLORMAPNUMBERREADER
                        (CREATE.NUMBERPAD.READER '(Enter color number to edit%:)
                               (create POSITION
                                      XCOORD _ LASTMOUSEX
                                      YCOORD _ LASTMOUSEY]
                 (create POSITION
                        XCOORD _ LASTMOUSEX
                        YCOORD _ LASTMOUSEY))
      LP  (COND
             ([NULL (ERSETQ (SETQ RESPONSE (NUMBERPAD.READ EDIT8BITCOLORMAPNUMBERREADER]
          
          (* currently there is no way NIL can be returned from NUMBERPAD.READ but there 
          should be a way to quit.)

              (RETURN NIL))
             ((OR (ILESSP RESPONSE 0)
                  (IGREATERP RESPONSE 255))
              (PROMPTPRINT "Color numbers must be between 0 and 255.")
              (GO LP))
             (T (RETURN RESPONSE])

(GETCOLOR#FROMSCREEN
  [LAMBDA NIL                                                (* rrb " 3-NOV-82 13:57")
          
          (* returns the color number of a point selected by the user.)

    (RESETFORM (CHANGECURSORSCREEN (COLORSCREENBITMAP))
           (PROG (POS)
                 (SETQ POS (GETPOSITION))
                 (RETURN (AND POS (BITMAPBIT (COLORSCREENBITMAP)
                                         (fetch (POSITION XCOORD) of POS)
                                         (fetch (POSITION YCOORD) of POS])

(DISPLAYCOLORLEVEL
  [LAMBDA (WINDOW COMPONENT NEWLEVEL WINDOWLEVEL)            (* kbr%: " 4-Jun-86 20:23")
    (PROG (REGION)
          (WINDOWPROP WINDOW COMPONENT WINDOWLEVEL)
          (SETQ REGION (SELECTQ COMPONENT
                           (RED (WINDOWPROP WINDOW 'REDREGION))
                           (BLUE (WINDOWPROP WINDOW 'BLUEREGION))
                           (GREEN (WINDOWPROP WINDOW 'GREENREGION))
                           (HUE (WINDOWPROP WINDOW 'HUEREGION))
                           (LIGHTNESS (WINDOWPROP WINDOW 'LIGHTNESSREGION))
                           (SATURATION (WINDOWPROP WINDOW 'SATURATIONREGION))
                           (SHOULDNT)))
          [PROGN                                             (* Print out new level of COMPONENT.
                                                             *)
                 (MOVETO (IDIFFERENCE (fetch (REGION LEFT) of REGION)
                                12)
                        (IPLUS 8 (fetch (REGION TOP) of REGION))
                        WINDOW)
          
          (* Overstrike extra digits in case the old value was larger.
          *)

                 (COND
                    ((FIXP NEWLEVEL)
                     (printout WINDOW " " |.I3| NEWLEVEL))
                    (T (printout WINDOW |.F5.3| NEWLEVEL]
          (FILLINREGION REGION WINDOWLEVEL GRAYSHADE WINDOW])

(FILLINREGION
  [LAMBDA (REGION HEIGHT GRAY WINDOW)                        (* rrb "23-FEB-82 12:26")
                                                             (* fills part of a region with gray.)
    (DSPFILL REGION WHITESHADE 'REPLACE WINDOW)
    (AREAFILL (fetch (REGION LEFT) of REGION)
           (fetch (REGION BOTTOM) of REGION)
           (fetch (REGION WIDTH) of REGION)
           HEIGHT GRAY 'REPLACE WINDOW])

(AREAFILL
  [LAMBDA (LFT BTM WDTH HGTH SHADE OPERATION WINDOW)         (* fills an area of a window with 
                                                             shade.)
    (BITBLT NIL NIL NIL WINDOW LFT BTM WDTH HGTH 'TEXTURE OPERATION SHADE])

(CENTEREDLEFT
  [LAMBDA (WIDTH LEFT RIGHT)                                 (* rrb "16-FEB-82 14:58")
          
          (* returns the left point that would leave WIDTH centered between LEFT and 
          RIGHT)

    (IQUOTIENT (IDIFFERENCE (IPLUS LEFT RIGHT)
                      WIDTH)
           2])

(OUTLINEAREA
  [LAMBDA (LFT BTM WDTH HGHT LINEWIDTH OPERATION WIN)        (* rrb "17-FEB-82 10:59")
                                                             (* outlines an area of a window.)
    (PROG (LEFTPLUSWIDTH RIGHTLINELEFT VERTLINETOP TOPY LINEWIDTH)
          (SETQ LINEWIDTH (OR (NUMBERP LINEWIDTH)
                              1))
          (SETQ LFT (IDIFFERENCE LFT LINEWIDTH))
          (SETQ BTM (IDIFFERENCE BTM LINEWIDTH))
          (SETQ WDTH (IPLUS WDTH (ITIMES LINEWIDTH 2)))
          (SETQ HGHT (IPLUS HGHT (ITIMES LINEWIDTH 2)))
          (DRAWLINE LFT BTM LFT (SETQ VERTLINETOP (SUB1 (IPLUS BTM HGHT)))
                 LINEWIDTH OPERATION WIN)
          (DRAWLINE (SETQ RIGHTLINELEFT (IDIFFERENCE (IPLUS LFT WDTH)
                                               LINEWIDTH))
                 BTM RIGHTLINELEFT VERTLINETOP LINEWIDTH OPERATION WIN)
          (DRAWLINE (SETQ LEFTPLUSWIDTH (IPLUS LFT LINEWIDTH))
                 BTM
                 (SETQ RIGHTLINELEFT (SUB1 RIGHTLINELEFT))
                 BTM LINEWIDTH OPERATION WIN)
          (DRAWLINE LEFTPLUSWIDTH (SETQ TOPY (ADD1 (IDIFFERENCE VERTLINETOP LINEWIDTH)))
                 RIGHTLINELEFT TOPY LINEWIDTH OPERATION WIN])

(OUTLINEREGION
  [LAMBDA (REGION OUTLINEWIDTH OPERATION WIN)                (* rrb "17-FEB-82 10:58")
                                                             (* outlines the region REGION with a 
                                                             width wide line)
    (OUTLINEAREA (fetch (REGION LEFT) of REGION)
           (fetch (REGION BOTTOM) of REGION)
           (fetch (REGION WIDTH) of REGION)
           (fetch (REGION HEIGHT) of REGION)
           OUTLINEWIDTH OPERATION WIN])
)
(DEFINEQ

(ADJUSTCOLORMAP
  [LAMBDA (PRIMARY DELTA)                                    (* kbr%: " 5-Jun-86 19:41")
          
          (* Adds DELTA points of intensity to all values of PRIMARY color in 
          SCREENCOLORMAP *)

    (PROG NIL
          (for COLOR from 0 to (MAXIMUMCOLOR (BITSPERPIXEL (SCREENCOLORMAP)))
             do (COLORLEVEL COLOR PRIMARY (IMIN 255 (IMAX 0 (IPLUS (COLORLEVEL COLOR PRIMARY)
                                                                   DELTA])

(SHOWCOLORBLOCKS
  [LAMBDA (DESTINATION)                                      (* kbr%: "17-Aug-85 21:44")
                                                             (* Puts shade blocks onto DESTINATION.
                                                             *)
    (PROG (BITSPERPIXEL MAXSHADE N WIDTH HEIGHT SHADE)
          (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION))
          (SETQ MAXSHADE (MAXIMUMSHADE BITSPERPIXEL))
          [SETQ N (FIXR (SQRT (ADD1 MAXSHADE]
          (SETQ WIDTH (IQUOTIENT (IPLUS (BITMAPWIDTH DESTINATION)
                                        N -1)
                             N))
          (SETQ HEIGHT (IQUOTIENT (IPLUS (BITMAPHEIGHT DESTINATION)
                                         N -1)
                              N))
          (SETQ SHADE 0)
          (for Y from (SUB1 N) to 0 by -1 do (for X from 0 to (SUB1 N)
                                                do (BLTSHADE SHADE DESTINATION (ITIMES X WIDTH)
                                                          (ITIMES Y HEIGHT)
                                                          WIDTH HEIGHT 'REPLACE)
                                                   (SETQ SHADE (ADD1 SHADE))
                                                   (COND
                                                      ((IGREATERP SHADE MAXSHADE)
                                                       (SETQ SHADE 0])

(MAPOFACOLOR
  [LAMBDA (RGB BITSPERPIXEL)                                 (* kbr%: "11-Jul-85 20:04")
                                                             (* creates a gray color map *)
    (PROG (MAXCOLOR RED GREEN BLUE OPRED OPGREEN OPBLUE COLORMAP)
          (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL))
          (SETQ RED (fetch (RGB RED) of RGB))
          (SETQ GREEN (fetch (RGB GREEN) of RGB))
          (SETQ BLUE (fetch (RGB BLUE) of RGB))
          (SETQ OPRED (IDIFFERENCE MAXCOLOR RED))
          (SETQ OPGREEN (IDIFFERENCE MAXCOLOR GREEN))
          (SETQ OPBLUE (IDIFFERENCE MAXCOLOR BLUE))
          (SETQ COLORMAP
           (COLORMAPCREATE (for I from 0 to MAXCOLOR as OPI from MAXCOLOR to 0 by -1
                              collect (create RGB
                                             RED _ (IQUOTIENT (IPLUS (ITIMES OPI OPRED)
                                                                     (ITIMES I RED))
                                                          MAXCOLOR)
                                             GREEN _ (IQUOTIENT (IPLUS (ITIMES OPI OPGREEN)
                                                                       (ITIMES I GREEN))
                                                            MAXCOLOR)
                                             BLUE _ (IQUOTIENT (IPLUS (ITIMES OPI OPBLUE)
                                                                      (ITIMES I BLUE))
                                                           MAXCOLOR)))
                  BITSPERPIXEL))
          (RETURN COLORMAP])

(COLORHEXPATTERN
  [LAMBDA (LIGHTNESS)                                        (* kbr%: " 3-Jun-86 22:36")
          
          (* Put a color hex pattern on the color display.
          *)

    (PROG (DESTINATION WIDTH HEIGHT BITSPERPIXEL N HEXWIDTH HEXHEIGHT LEFT BOTTOM COLOR MAXI JDIST 
                 IDIST)
          (COND
             ((NULL LIGHTNESS)
              (SETQ LIGHTNESS 0.5)))
          (SETQ DESTINATION (COLORSCREENBITMAP))
          (SETQ WIDTH (BITMAPWIDTH DESTINATION))
          (SETQ HEIGHT (BITMAPHEIGHT DESTINATION))
          (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION))
          (SETQ N (SELECTQ BITSPERPIXEL
                      (4 1)
                      (8 8)
                      (RETURN)))
          (SETQ HEXWIDTH (IQUOTIENT WIDTH (IPLUS (ITIMES 2 N)
                                                 1)))
          (SETQ HEXHEIGHT (IQUOTIENT HEIGHT (IPLUS (ITIMES 2 N)
                                                   1)))
          (BLTSHADE MINIMUMSHADE DESTINATION)
          (SETQ COLOR 0)
          [for J from N to 0 by -1
             do (SETQ BOTTOM (ITIMES (IPLUS J N)
                                    HEXHEIGHT))
                (SETQ MAXI (IDIFFERENCE (IPLUS (ITIMES 2 N)
                                               1)
                                  J))
                (for I from 0 to MAXI
                   do (SETQ LEFT (IQUOTIENT (ITIMES (IPLUS (ITIMES 2 I)
                                                           J)
                                                   HEXWIDTH)
                                        2))
                      (SETQ COLOR (ADD1 COLOR))
                      (BLTSHADE COLOR DESTINATION LEFT BOTTOM HEXWIDTH HEXHEIGHT)
                      (SETQ JDIST (FQUOTIENT J N))
                      (SETQ IDIST (FDIFFERENCE (FTIMES 2.0 (FQUOTIENT I MAXI))
                                         1.0))
                      (SCREENCOLORMAPENTRY COLOR (HLSTORGB (ATAN JDIST IDIST)
                                                        LIGHTNESS
                                                        (SQRT (FQUOTIENT (FPLUS (FTIMES IDIST IDIST)
                                                                                (FTIMES JDIST JDIST))
                                                                     2.0]
          (for J from -1 to (IMINUS N) by -1
             do (SETQ BOTTOM (ITIMES (IPLUS J N)
                                    HEXHEIGHT))
                (SETQ MAXI (IPLUS (IPLUS (ITIMES 2 N)
                                         1)
                                  J))
                (for I from 0 to MAXI
                   do (SETQ LEFT (IQUOTIENT (ITIMES (IPLUS (ITIMES 2 I)
                                                           (IMINUS J))
                                                   HEXWIDTH)
                                        2))
                      (SETQ COLOR (ADD1 COLOR))
                      (BLTSHADE COLOR DESTINATION LEFT BOTTOM HEXWIDTH HEXHEIGHT)
                      (SETQ JDIST (FQUOTIENT J N))
                      (SETQ IDIST (FDIFFERENCE (FTIMES 2.0 (FQUOTIENT I MAXI))
                                         1.0))
                      (SCREENCOLORMAPENTRY COLOR (HLSTORGB (ATAN JDIST IDIST)
                                                        LIGHTNESS
                                                        (SQRT (FQUOTIENT (FPLUS (FTIMES IDIST IDIST)
                                                                                (FTIMES JDIST JDIST))
                                                                     2.0])
)

(RPAQQ EditColorMapHeight 315)

(RPAQQ EditColorMapWidth 380)

(RPAQQ COLOR#MENUSAVE NIL)

(RPAQQ CONTROLMENUSAVE NIL)

(RPAQQ EDIT8BITCOLORMAPMENU NIL)

(RPAQQ EDIT8BITCOLORMAPNUMBERREADER NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS COLOR#MENUSAVE CONTROLMENUSAVE EDIT8BITCOLORMAPMENU EDIT8BITCOLORMAPNUMBERREADER 
       EditColorMapHeight EditColorMapWidth)
)



(* ;;; "support for global naming and querying of colors.")

(DEFINEQ

(CNSMENUINIT
  [LAMBDA NIL                                                (* gbn " 9-Aug-85 03:11")
    [SETQ CNSHUEMENU (create MENU
                            ITEMS _ (for I in DICOLOR.hueMapping collect (CAR I]
    [SETQ CNSSATURATIONMENU (create MENU
                                   ITEMS _ (for I in DICOLOR.saturationMapping
                                              collect (CAR I]
    (SETQ CNSLIGHTNESSMENU (create MENU
                                  ITEMS _ (for I in DICOLOR.lightnessMapping
                                             collect (CAR I])

(CNSTOCSL
  [LAMBDA (hue saturation lightness)                         (* hdj "12-Apr-85 19:01")
    (PROG ((hueAtom (MKATOM hue))
           (saturationAtom (MKATOM saturation))
           (lightnessAtom (MKATOM lightness))
           c s l)
          (if [NOT (SETQ c (fetch (hueRecord ordering) of (ASSOC hueAtom DICOLOR.hueMapping]
              then (SETQ c DICOLOR.achromatic))
          (if (EQ c DICOLOR.achromatic)
              then (SETQ s DICOLOR.noSaturation)
            else (if [NOT (SETQ s (fetch (saturationRecord ordering) of (ASSOC saturationAtom 
                                                                            DICOLOR.saturationMapping
                                                                               ]
                     then (SETQ s DICOLOR.vivid)))
          (SELECTQ hueAtom
              (Black (SETQ l DICOLOR.black))
              (White (SETQ l DICOLOR.white))
              (if [NOT (SETQ l (fetch (lightnessRecord ordering) of (ASSOC lightnessAtom 
                                                                           DICOLOR.lightnessMapping]
                  then (SETQ l DICOLOR.medium)))
          (RETURN (LIST c s l])

(CNSTORGB
  [LAMBDA (saturation lightness hue)                         (* hdj "15-Jul-85 12:33")
    (LET ((CSL (CNSTOCSL hue saturation lightness)))
         (HLSTORGB (APPLY (FUNCTION CSLTOHLS)
                          CSL])

(CSLTOCNS
  [LAMBDA (c s l)                                            (* hdj "15-Jul-85 12:37")
    (PROG (hue saturation lightness)
          [if (EQ c DICOLOR.achromatic)
              then (SETQ saturation "")
                   [SELECTC l
                       (DICOLOR.black (SETQ hue "Black")
                                      (SETQ lightness ""))
                       (DICOLOR.white (SETQ hue "White")
                                      (SETQ lightness ""))
                       (PROGN (SETQ hue "Gray")
                              (SETQ lightness (MKSTRING (fetch (lightnessRecord name)
                                                           of (DICOLOR.lightnessN l]
            else (SETQ hue (fetch (hueRecord name) of (DICOLOR.hueN c)))
                 (SETQ saturation (fetch (saturationRecord name) of (DICOLOR.saturationN s)))
                 (SETQ lightness (fetch (lightnessRecord name) of (DICOLOR.lightnessN l]
          (RETURN (LIST saturation lightness hue])

(DICOLOR.FROM.USER
  [LAMBDA NIL                                                (* gbn "30-Oct-85 11:28")
          
          (* * Returns a color, either by its name
          (which can then be looked up on colornames) or as an RGB triple if it is not 
          named. Prompts the user first with the global color name menu.
          She can then choose NEWCOLOR which can be specified as RGB or CNS)

    (PROG (NAME RGB)                                         (* first try to get a color name)
          [SETQ NAME (MENU (OR COLORNAMEMENU (SETQ COLORNAMEMENU
                                              (create MENU
                                                     ITEMS _ (CONS NEWCOLORITEM
                                                                   (for ENTRY in COLORNAMES
                                                                      collect (CAR ENTRY]
          (if (NOT NAME)
              then                                           (* the user clicked outside the menu)
                   (RETURN))
          (SETQ RGB (SELECTQ NAME
                        (RGB (READCOLOR1 "specify new color"))
                        (CNS (APPLY (FUNCTION CNSTORGB)
                                    (GETCNS)))
                        (RETURN NAME)))
          (if (NOT (SETQ NAME (TTYIN "New color name? ")))
              then 
          
          (* user decided that she didn't want to name the color)

                   (RETURN RGB))
          (push COLORNAMES (CONS (SETQ NAME (CAR NAME))
                                 RGB))
          (SETQ COLORNAMEMENU NIL)                           (* invalidate the menu)
          (RETURN NAME])

(GETCNS
  [LAMBDA NIL                                                (* gbn " 9-Aug-85 03:13")
    (LIST (MENU CNSLIGHTNESSMENU)
          (MENU CNSSATURATIONMENU)
          (MENU CNSHUEMENU])

(HLSTOCSL
  [LAMBDA (hue lightness saturation)                         (* hdj "15-Jul-85 12:14")
    (LET
     ((ISLHue (FQUOTIENT (MOD (PLUS hue 240)
                              360)
                     360)))
     (PROG (c s l)
           (for old s from DICOLOR.noSaturation to DICOLOR.vivid
              do (if (EQ s DICOLOR.vivid)
                     then (RETURN))
                 (if (LEQ saturation (PLUS (DICOLOR.saturationNvalue s)
                                           (QUOTIENT (DIFFERENCE (DICOLOR.saturationNvalue
                                                                  (ADD1 s))
                                                            (DICOLOR.saturationNvalue s))
                                                  2)))
                     then (RETURN)))
           [if (EQ s DICOLOR.noSaturation)
               then (SETQ c DICOLOR.achromatic)
                    (for old l from DICOLOR.black to DICOLOR.white
                       do (if (EQ l DICOLOR.white)
                              then (RETURN))
                          (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l)
                                                   (QUOTIENT (DIFFERENCE (DICOLOR.lightnessNvalue
                                                                          (ADD1 l))
                                                                    (DICOLOR.lightnessNvalue l))
                                                          2)))
                              then (RETURN)))
             else (for old c from DICOLOR.red to DICOLOR.purplishRed
                     do                                      (* (HELP c))
                        (if (EQ c DICOLOR.purplishRed)
                            then (if (GREATERP ISLHue (PLUS (DICOLOR.hueNvalue c)
                                                            (QUOTIENT (DIFFERENCE 1 (
                                                                                    DICOLOR.hueNvalue
                                                                                     c))
                                                                   2)))
                                     then (SETQ c DICOLOR.red))
                                 (RETURN))
                        (if (LEQ ISLHue (PLUS (DICOLOR.hueNvalue c)
                                              (QUOTIENT (DIFFERENCE (DICOLOR.hueNvalue (ADD1 c))
                                                               (DICOLOR.hueNvalue c))
                                                     2)))
                            then (RETURN)))
                  (for old l from DICOLOR.veryDark to DICOLOR.veryLight
                     do (if (EQ l DICOLOR.veryLight)
                            then (RETURN))
                        (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l)
                                                 (QUOTIENT (DIFFERENCE (DICOLOR.lightnessNvalue
                                                                        (ADD1 l))
                                                                  (DICOLOR.lightnessNvalue l))
                                                        2)))
                            then (RETURN]
           (RETURN (LIST c s l])

(CSLTOHLS
  [LAMBDA (c s l)                                            (* hdj "15-Jul-85 12:23")
    (PROG (hue saturation lightness)
          (if (EQ c DICOLOR.achromatic)
              then (SETQ hue 0.0)
                   (SETQ saturation 0.0)
                   (SETQ lightness (DICOLOR.lightnessNvalue l))
            else (SETQ hue (DICOLOR.hueNvalue c))
                 (SETQ saturation (DICOLOR.saturationNvalue s))
                 (SETQ lightness (DICOLOR.lightnessNvalue l)))
          (RETURN (LIST (MOD (FPLUS 120 (FTIMES hue 360))
                             360)
                        lightness saturation])

(RGBTOCNS
  [LAMBDA (Red Green Blue)                                   (* hdj "15-Jul-85 12:36")
    (APPLY (FUNCTION CSLTOCNS)
           (APPLY (FUNCTION HLSTOCSL)
                  (RGBTOHLS Red Green Blue])
)

(RPAQQ DICOLOR.hueMapping
       ((Achromatic 0.0 -1)
        (Red 0.0 0)
        (OrangishRed 0.01 1)
        (RedOrange 0.02 2)
        (ReddishOrange 0.03 3)
        (Orange 0.04 4)
        (YellowishOrange 0.07 5)
        (OrangeYellow 0.1 6)
        (OrangishYellow 0.13 7)
        (Yellow 0.1673 8)
        (GreenishYellow 0.2073 9)
        (YellowGreen 0.2473 10)
        (YellowishGreen 0.2873 11)
        (Green 0.3333 12)
        (BluishGreen 0.4133 13)
        (GreenBlue 0.4933 14)
        (GreenishBlue 0.5733 15)
        (Blue 0.6666 16)
        (PurplishBlue 0.6816 17)
        (BluePurple 0.6966 18)
        (BluishPurple 0.7116 19)
        (Purple 0.73 20)
        (ReddishPurple 0.8 21)
        (PurpleRed 0.87 22)
        (PurplishRed 0.94 23)
        (BrownishRed 0.01 24)
        (RedBrown 0.02 25)
        (ReddishBrown 0.03 26)
        (Brown 0.04 27)
        (YellowishBrown 0.07 28)
        (BrownYellow 0.1 29)
        (BrownishYellow 0.13 30)))

(RPAQQ DICOLOR.lightnessMapping ((Black 0.0 0)
                                     (VeryDark 0.1666 1)
                                     (Dark 0.3333 2)
                                     (Medium 0.5 3)
                                     (Light 0.6666 4)
                                     (VeryLight 0.8333 5)
                                     (White 1.0 6)))

(RPAQQ DICOLOR.saturationMapping ((NoSaturation 0.0 0)
                                      (Grayish 0.25 1)
                                      (Moderate 0.5 2)
                                      (Strong 0.75 3)
                                      (Vivid 1.0 4)))

(RPAQQ NEWCOLORITEM (New% Color 'CNS "Allows specification of a new color"
                               (SUBITEMS (RGB 'RGB 
                                              "Specify a new color using Red, Green, Blue sliders")
                                      (CNS 'CNS "Specify a new color using English"))))

(RPAQ? COLORNAMEMENU )
(DEFINEQ

(DICOLOR.hueN
  [LAMBDA (N)                                                (* hdj "17-Apr-85 13:38")
    (DECLARE (GLOBALVARS DICOLOR.hueMapping))
    (for ELT in DICOLOR.hueMapping suchthat (EQ (fetch (hueRecord ordering) of ELT)
                                                N])

(DICOLOR.hueNvalue
  [LAMBDA (N)                                                (* hdj "18-Apr-85 09:58")
    (fetch (hueRecord value) of (DICOLOR.hueN N])

(DICOLOR.hueNname
  [LAMBDA (N)                                                (* hdj "18-Apr-85 10:07")
    (fetch (hueRecord name) of (DICOLOR.hueN N])

(DICOLOR.lightnessN
  [LAMBDA (N)                                                (* hdj "17-Apr-85 13:40")
    (DECLARE (GLOBALVARS DICOLOR.lightnessMapping))
    (for ELT in DICOLOR.lightnessMapping suchthat (EQ (fetch (lightnessRecord ordering) of ELT)
                                                      N])

(DICOLOR.lightnessNvalue
  [LAMBDA (N)                                                (* hdj "17-Apr-85 13:36")
    (fetch (lightnessRecord value) of (DICOLOR.lightnessN N])

(DICOLOR.lightnessNname
  [LAMBDA (N)                                                (* hdj "17-Apr-85 14:02")
    (fetch (lightnessRecord name) of (DICOLOR.lightnessN N])

(DICOLOR.saturationN
  [LAMBDA (N)                                                (* hdj "17-Apr-85 13:39")
    (DECLARE (GLOBALVARS DICOLOR.saturationMapping))
    (for ELT in DICOLOR.saturationMapping suchthat (EQ (fetch (saturationRecord ordering)
                                                          of ELT)
                                                       N])

(DICOLOR.saturationNvalue
  [LAMBDA (N)                                                (* hdj "17-Apr-85 13:36")
    (fetch (saturationRecord value) of (DICOLOR.saturationN N])

(DICOLOR.saturationNname
  [LAMBDA (N)                                                (* hdj "17-Apr-85 14:02")
    (fetch (saturationRecord name) of (DICOLOR.saturationN N])
)
(DECLARE%: EVAL@LOAD DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD hueRecord (name value ordering))

(RECORD lightnessRecord (name value ordering))

(RECORD saturationRecord (name value ordering))
)


(RPAQQ DICOLOR.hueConstants
       (DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple 
              DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow 
              DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow 
              DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow 
              DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red 
              DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange 
              DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown 
              DICOLOR.yellowishGreen DICOLOR.yellowishOrange))
(DECLARE%: EVAL@COMPILE 

(RPAQQ DICOLOR.achromatic -1)

(RPAQQ DICOLOR.blue 16)

(RPAQQ DICOLOR.bluePurple 18)

(RPAQQ DICOLOR.bluishGreen 13)

(RPAQQ DICOLOR.bluishPurple 19)

(RPAQQ DICOLOR.brown 27)

(RPAQQ DICOLOR.brownYellow 29)

(RPAQQ DICOLOR.brownishRed 24)

(RPAQQ DICOLOR.brownishYellow 30)

(RPAQQ DICOLOR.green 12)

(RPAQQ DICOLOR.greenBlue 14)

(RPAQQ DICOLOR.greenishBlue 15)

(RPAQQ DICOLOR.greenishYellow 9)

(RPAQQ DICOLOR.orange 4)

(RPAQQ DICOLOR.orangeYellow 6)

(RPAQQ DICOLOR.orangishRed 1)

(RPAQQ DICOLOR.orangishYellow 7)

(RPAQQ DICOLOR.purple 20)

(RPAQQ DICOLOR.purpleRed 22)

(RPAQQ DICOLOR.purplishBlue 17)

(RPAQQ DICOLOR.purplishRed 23)

(RPAQQ DICOLOR.red 0)

(RPAQQ DICOLOR.redBrown 25)

(RPAQQ DICOLOR.redOrange 2)

(RPAQQ DICOLOR.reddishBrown 26)

(RPAQQ DICOLOR.reddishOrange 3)

(RPAQQ DICOLOR.reddishPurple 21)

(RPAQQ DICOLOR.yellow 8)

(RPAQQ DICOLOR.yellowGreen 10)

(RPAQQ DICOLOR.yellowishBrown 28)

(RPAQQ DICOLOR.yellowishGreen 11)

(RPAQQ DICOLOR.yellowishOrange 5)


(CONSTANTS DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen 
       DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed 
       DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue 
       DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed 
       DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue 
       DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown 
       DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen 
       DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange)
)


(RPAQQ DICOLOR.saturationConstants (DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate 
                                              DICOLOR.strong DICOLOR.vivid))
(DECLARE%: EVAL@COMPILE 

(RPAQQ DICOLOR.noSaturation 0)

(RPAQQ DICOLOR.grayish 1)

(RPAQQ DICOLOR.moderate 2)

(RPAQQ DICOLOR.strong 3)

(RPAQQ DICOLOR.vivid 4)


(CONSTANTS DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid)
)


(RPAQQ DICOLOR.lightnessConstants (DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium 
                                             DICOLOR.light DICOLOR.veryLight DICOLOR.white))
(DECLARE%: EVAL@COMPILE 

(RPAQQ DICOLOR.black 0)

(RPAQQ DICOLOR.veryDark 1)

(RPAQQ DICOLOR.dark 2)

(RPAQQ DICOLOR.medium 3)

(RPAQQ DICOLOR.light 4)

(RPAQQ DICOLOR.veryLight 5)

(RPAQQ DICOLOR.white 6)


(CONSTANTS DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight
       DICOLOR.white)
)
)

(CNSMENUINIT)

(FILESLOAD LLCOLOR READNUMBER)

(SETQ EDITBMMENU NIL)

(MOVD 'ARRAYP 'COLORMAPP)
(PUTPROPS COLOR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1985 1986 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2486 17538 (DISPLAYCOLORLEVELS 2496 . 3614) (DISPLAYHLSLEVELS 3616 . 3956) (HLSLEVEL 
3958 . 4693) (HLSTORGB 4695 . 6124) (HLSVALUEFN 6126 . 7003) (HLSVALUEFROMLEVEL 7005 . 7337) (
LEVELFROMHLSVALUE 7339 . 7676) (RAINBOWMAP 7678 . 14687) (RGBTOHLS 14689 . 17536)) (17539 19325 (
OVERPAINT 17549 . 18310) (BITMAPFROMSTRING 18312 . 18802) (SHADEBITMAP 18804 . 19323)) (19363 35973 (
EDITCOLORMAP 19373 . 20592) (EDITCOLORMAP.BUTTONEVENTFN 20594 . 24324) (EDITCOLORMAP.REDISPLAYFN 24326
 . 26685) (EDITCOLORMAP.VALUELEVEL 26687 . 27180) (EDITCOLORMAP.WINDOWLEVEL 27182 . 27685) (
CHANGECOLORLEVELS 27687 . 29814) (GETCOLOR#FROMUSER 29816 . 31134) (GETCOLOR#FROMSCREEN 31136 . 31694)
 (DISPLAYCOLORLEVEL 31696 . 33120) (FILLINREGION 33122 . 33589) (AREAFILL 33591 . 33853) (CENTEREDLEFT
 33855 . 34181) (OUTLINEAREA 34183 . 35412) (OUTLINEREGION 35414 . 35971)) (35974 43347 (
ADJUSTCOLORMAP 35984 . 36504) (SHOWCOLORBLOCKS 36506 . 37973) (MAPOFACOLOR 37975 . 39626) (
COLORHEXPATTERN 39628 . 43345)) (43813 53415 (CNSMENUINIT 43823 . 44458) (CNSTOCSL 44460 . 45722) (
CNSTORGB 45724 . 45971) (CSLTOCNS 45973 . 47046) (DICOLOR.FROM.USER 47048 . 48807) (GETCNS 48809 . 
49013) (HLSTOCSL 49015 . 52515) (CSLTOHLS 52517 . 53185) (RGBTOCNS 53187 . 53413)) (55398 57649 (
DICOLOR.hueN 55408 . 55726) (DICOLOR.hueNvalue 55728 . 55907) (DICOLOR.hueNname 55909 . 56086) (
DICOLOR.lightnessN 56088 . 56436) (DICOLOR.lightnessNvalue 56438 . 56635) (DICOLOR.lightnessNname 
56637 . 56832) (DICOLOR.saturationN 56834 . 57245) (DICOLOR.saturationNvalue 57247 . 57447) (
DICOLOR.saturationNname 57449 . 57647)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/COLOR.TEdit b/internal/library/OBSOLETE/COLOR.TEdit
new file mode 100644
index 00000000..2af60f2f
--- /dev/null
+++ b/internal/library/OBSOLETE/COLOR.TEdit
@@ -0,0 +1,222 @@
+1

KALEIDOSCOPE MANUAL - 16-JAN-89 - Dev. Draft
1

KALEIDOSCOPE MANUAL - 16-JAN-89 - Dev. Draft
COLOR
1

ENVOS KALEIDOSCOPE
1

COLOR
6

2

Introduction
1

This document describes software for driving color displays.  In order to run COLOR, you need either a Sun (3 or 4) with CG4 color hardware and display, a Dorado (Xerox 1132) with attached color display, or a Dandelion (Xerox 1108) with attached BusMaster and color display.
The color software which is distributed among a number of files can be divided into a machine independent group of files that all users can usefully load and a machine dependent group containing files that work for particular combinations of hardware.
The machine independent color graphics code is stored in the library files LLCOLOR.LCOM and COLOR.LCOM.  LOADing COLOR.LCOM causes LLCOLOR.LCOM to be LOADed.
The machine dependent portions of Xerox Lisp color software is stored in files such as MAIKOCOLOR.LCOM, DORADOCOLOR.LCOM, or COLORNNCC.LCOM.  The user LOADs one of these files according to what kind of machine and color card the user is using.
The Sun color driver resides in the file MAIKOCOLOR.LCOM which loads LLCOLOR.LCOM and COLOR.LCOM.  The CG4 device suppports 8 bpp at  1152 by 900 resolution.  The user must be running ldecolor, the special color capable emulator.  The physical display monitor is shared by both the monochrome and color screens (described below) .
The Dorado color driver resides in the file DORADOCOLOR.LCOM which loads LLCOLOR.LCOM and  COLOR.LCOM.  The  Dorado color board supports four or eight bits per pixel  (bpp) at 640 by 480 resolution.  (The board supports 24 bpp also, but Xerox Lisp doesn't yet.) 
The Dandelion color drivers reside in the files DANDELIONUFO.LCOM, DANDELIONUFO4096.LCOM, and COLORNNCC.LCOM, one package for each of three different kinds of boards.  The user should load one of these packages on a Dandelion attached to a BusMaster and color display.  The DANDELIONUFO and DANDELIONUFO4096 packages drive 4 bpp at 640 by 400 resolution color boards used inside Xerox which have been made obsolete by COLORNNCC.  The COLORNNCC package drives an 8 bpp color  at 512 by 480 resolution board, the Revolution 512 x 8, made by Number Nine Computer Corporation.  The Revolution 512 x 8 is available both inside and outside Xerox through Number Nine.
2

Hardware Displays and Software Screens
1

On some workstations (such as the Dorado and Dandelion), there may be physically two separate displays.  On most Suns, there is a single physical display, which additionally may be shared by two Unix devices.  One device is monochrome (b/w), and the other is color.
To support the various hardware configurations and external display devices, the software has a special datatype, a "screen".  There are two distinct instances of screens, a b/w screen, and a color screen.  A screen represents and controls a physical hardware display, and contains windows, icons, and tracks the mouse.
On workstations with physically two separate hardware displays, each display is represented by a corresponding screen data structure.  On workstations with a single hardware display, the display is shared by both the b/w screen and the color screen.
In all cases, before initialization only the b/w screen (and thus display) is visible and active.  After initialization both screens are active (can contain screen images), although on single displays, only one screen is visible at a time.  Since each screen logically controls a display, we will henceforth use the terms "screen" and "display" interchangeably.  Screens are discussed in greater detail below.
2

Turning the Color Display Software On and Off
1

The color display software can be turned on and off.  While the color display software is on, the memory used for the color display screen bitmap is locked down, and a small amount of processing time is used to drive the color display.  
(COLORDISPLAYP)	[Function]
returns T if the color display is on; otherwise it returns NIL.
(COLORDISPLAYONOFF TYPE)	[Function]
turns off the color display if ONOFF is 'OFF.   If ONOFF is 'ON, it turns on the color display allocating memory for the color screen bitmap.  TYPE should be one of 'MAIKOCOLOR, 'DORADOCOLOR, 'DANDELIONUFO, 'DANDELIONUFO4096, or 'COLORNNCC.  The usual sequence of events for the user is to LOAD the software needed to drive a particular color card and then to call COLORDISPLAY with the appropriate TYPE to turn the software on.  For example,
     (LOAD 'COLOR.LCOM)
     (LOAD 'COLORNNCC.LCOM)
     (COLORDISPLAY 'ON 'REV512X8)
will turn on the software needed to drive the Number Nine Computer Corporation's Revolution 512 x 8 card with 1108 and BusMaster.
Besides initializing or reinitializing a color card that has been powered off, COLORDISPLAY allocates memory for the color screen bitmap.  Turning on the color display requires allocating and locking down the memory necessary to hold the color display screen bitmap.  Turning off the color display frees this memory.
2

Colors  
1

The number of bits per pixel determines the number of different colors that can be displayed at one time.  When there are 4 bpp, 16 colors can be displayed at once.  When there are 8 bpp, 256 colors can be displayed at once.  A table called a color map determines what color actually appears for each pixel value.   A color map gives the color in terms of how much of the three primary colors (red, green, and blue) is displayed on the screen for each possible pixel value.
A color can be represented as a number, an atom, or a triple of numbers.  Colors are ultimately given their final interpretation into how much red, blue, and green they represent through a color map.  A color map maps a color number ([0 . . . 2nbits-1]) into the intensities of the three color guns (primary colors red, green, and blue).  Each entry in the color map has eight bits for each of the primary colors, allowing 256 levels per primary or 224 possible colors (not all of which are distinct to the human eye).  Within Xerox Lisp programs, colors can be manipulated as numbers, red-green-blue triples, names, or hue-lightness-saturation triples.  Any function that takes a color accepts any of the different representations.
If a number is given, it is the color number used in the operation.  It must be valid for the color bitmap used in the operation.  (Since all of the routines that use a color need to determine its number, it is fastest to use numbers for colors.  COLORNUMBERP, described below, provides a way to translate into numbers from the other representations.)
Red Green Blue Triples
1

A red green blue (RGB) triple is a list of three numbers between 0 and 255.  The first element gives the intensity for red, the second for green, and the third for blue.  When an RGB triple is used, the current color map is searched to find the color with the correct intensities.  If none is found, an error is generated. (That is, no attempt is made by the system to assign color numbers to intensities automatically.)  An example of an RGB triple is (255 255 255), which gives the color white.
RGB	[Record]
is a record  that  is defined as (RED GREEN BLUE); it can be used to manipulate RGB triples.
COLORNAMES 	[Association list]
maps names into colors.  The CDR of the color name's entry is used as the color corresponding to the color name.  This can be any of the other representations. (Note: It can even be another color name.  Loops in the name space such as would be caused by putting '(RED . CRIMSON) and '(CRIMSON . RED) on COLORNAMES are not checked for by the system.)  Some color names are available in the initial system and are intended to allow color programs written by different users to coexist.  These are:
Name	RGB	Number in default color maps
BLACK	(0 0 0)	15	  255
BLUE	(0 0 255)	14	  252
GREEN	(0 255 0)	13	  227
CYAN	(0 255 255)	12	  224
RED	(255 0 0)	3	     31
MAGENTA	(255 0 255)	2	     28
YELLOW	(255 255 0)	1	     3
WHITE	(255 255 255)	0	     0
Hue Lightness Saturation Triples
1

A hue lightness saturation triple is a list of three numbers.  The first number (HUE) is an integer between 0 and 355 and indicates a position in degrees on a color wheel (blue at 0, red at 120, and green at 240). The second (LIGHTNESS) is a real number between zero and one that indicates how much total intensity is in the color.  The third (SATURATION) is a real number between zero and one that indicates how disparate the three primary levels are.
HLS	[Record]
is a record defined as (HUE LIGHTNESS SATURATION); it is provided to manipulate HLS triples.  Example: the color blue is represented in HLS notation by (0 .5 1.0).
(COLORNUMBERP COLOR BITSPERPIXEL NOERRFLG)	[Function]
returns the color number (offset into the screen color map) of COLOR.  COLOR is one of the following:
�  A positive number less than the maximum number of colors,
�  A color name,
�  AN RGB triple,  or
�  An HLS triple.
If COLOR is one of the above and is found in the screen color map, its color number in the screen color map is returned.  If not, an error is generated unless NOERRFLG is non-NIL, in which case NIL is returned.
(RGBP X)	[Function]
returns X if X is an RGB triple; NIL otherwise.
(HLSP X)	[Function]
returns X if X is an HLS triple; NIL otherwise.
2

Color Maps	
1

The screen color map holds the information about what color is displayed on the color screen for each pixel value in the color screen bitmap.  The values in the current screen color map may be changed, and this change is reflected in the colors displayed at the next vertical retrace (approximately 1/30 of a second). The color map can be changed to obtain dramatic effects.  
(SCREENCOLORMAP NEWCOLORMAP)	[Function]
reads and sets the color map that is used by the color display.  If NEWCOLORMAP is non-NIL, it should be a color map, and SCREENCOLORMAP sets the system color map to be that color map.  The value returned is the value of the screen color map before SCREENCOLORMAP was called.  If NEWCOLORMAP is NIL, the current screen color map is returned without change.
(CMYCOLORMAP CYANBITS MAGENTABITS YELLOWBITS BITSPERPIXEL)	[Function]
Returns a color map that assumes the BITSPERPIXEL bits are to be treated as three separate color planes with CYANBITS bits being in the cyan plane, MAGENTABITS bits being in the magenta plane, and YELLOWBITS bits being in the yellow plane.  Within each plane, the colors are uniformly distributed over the intensity range 0 to 255.  White is 0 and black is 255. 
(RGBCOLORMAP REDBITS GREENBITS BLUEBITS BITSPERPIXEL)	[Function]
Returns a color map that assumes the BITSPERPIXEL bits are to be treated as three separate color planes with REDBITS bits being in the red plane, GREENBITS bits being in the green plane, and BLUEBITS bits being in the blue plane.  Within each plane, the colors are uniformly distributed over the intensity range 0 to 255.  White is 255 and black is 0. 
(GRAYCOLORMAP BITSPERPIXEL)	[Function]
Returns a color map containing shades of gray.  White is 0 and black is 255. 
(COLORMAPCREATE INTENSITIES BITSPERPIXEL)	[Function]
creates a color map for a screen that has BITSPERPIXEL bits per pixel.  If BITSPERPIXEL is NIL, the number of bits per pixel is taken from the current color display setting.  INTENSITIES specifies the initial colors that should be in the map.  If INTENSITIES is not NIL, it should be a list of color specifications other than color numbers, e.g., the list of RGB triples returned by the function INTENSITIESFROMCOLOR MAP. 
(INTENSITIESFROMCOLORMAP COLORMAP)	[Function]
returns a list of the intensity levels of COLORMAP (default is (SCREENCOLORMAP)) in a form accepted by COLORMAPCREATE.  This list can be written on file and thus provides a way of saving color map specifications.
(COLORMAPCOPY COLORMAP BITSPERPIXEL)	[Function]
returns a color map that contains the same color intensities as COLORMAP if COLORMAP is a color map. Otherwise, it returns a color map with default color values.
(MAPOFACOLOR PRIMARIES)	[Function]
returns a color map that is different shades of one or more of the primary colors.  For example, (MAPOFACOLOR '(RED GREEN BLUE))  gives a color map of different shades of gray; (MAPOFACOLOR 'RED) gives different shades of red.
Changing Color Maps
1


The following functions are provided to access and change the intensity levels in a color map.
(SETCOLORINTENSITY COLORMAP COLORNUMBER 
                                               COLORSPEC)	[Function]
sets the primary intensities of color number COLORNUMBER in the color map COLORMAP to the ones specified by COLORSPEC. COLORSPEC can be either an RGB triple, an HLS triple, or a color name.  The value returned is NIL.
(COLORLEVEL COLORMAP COLORNUMBER PRIMARY
                              NEWLEVEL)	  [Function]
sets and reads the intensity level of the primary color PRIMARY (RED, GREEN, or BLUE) for the color number COLORNUMBER in the color map COLORMAP.  If NEWLEVEL is a number between 0 and 255, it is set.  The previous value of the intensity of PRIMARY is returned.
(ADJUSTCOLORMAP PRIMARY DELTA COLORMAP)	[Function]
adds DELTA to the intensity of the PRIMARY color value (RED, GREEN, or BLUE) for every color number in COLORMAP.
(ROTATECOLORMAP STARTCOLOR THRUCOLOR)	[Function]
rotates a sequence of colors in the SCREENCOLORMAP.  The rotation moves the intensity values of color number STARTCOLOR into color number STARTCOLOR+1, the intensity values of color number STARTCOLOR+1 into color number STARTCOLOR+2, etc., and THRUCOLOR's values into STARTCOLOR.
(EDITCOLORMAP VAR NOQFLG)	[Function]
allows interactive editing of a color map.  If VAR is an atom whose value is a color map, its value is edited.  Otherwise a new color map is created and edited.  The color map being edited is made the screen color map while the editing takes place so that its effects can be observed.  The edited color map is returned as the value.  If NOQFLG is NIL and the color display is on, you are asked if you want a test pattern of colors.  A yes response causes the function SHOWCOLORTESTPATTERN to be called, which displays a test pattern with blocks of each of the possible colors.
You are prompted for the location of a color control window to be placed on the black-and-white display.  This window allows the value of any of the colors to be changed.  The number of the color being edited is in the upper left part of the window.  Six bars are displayed.  The right three bars give the color intensities for the three primary colors of the current color number.  The left three bars give the value of the color's Hue, Lightness, and Saturation parameters. These levels can be changed by positioning the mouse cursor in one of the bars and pressing the left mouse button.  While the left button is down, the value of that parameter tracks the Y position of the cursor.  When the left button is released, the color tracking stops.  The color being edited is changed by pressing the middle mouse button while the cursor is in the interior of the edit window.  This brings up a menu of color numbers.  Selecting one sets the current color to the selected color.
The color being edited can also be changed by selecting the menu item "PickPt."  This switches the cursor onto the color screen and allows you to select a point from the color screen.  It then edits the color of the selected point.
To stop the editing, move the cursor into the title of the editing window and press the middle button.  This brings up a menu.  Select Stop to quit. 
2

Color Bitmaps
1

A color bitmap is actually a bitmap that has more than one bit per pixel.  To test whether a bitmap is a color bitmap, the function BITSPERPIXEL can be used.
(BITSPERPIXEL BITMAP)	[Function]
returns the bits per pixel of BITMAP; if this does not equal one, BITMAP is a color bitmap.
In multiple-bit-per-pixel bitmaps, the bits that represent a pixel are stored contiguously.  BITMAPCREATE is passed a BITSPERPIXEL argument to create multiple-bit-per-pixel bitmaps.
(BITMAPCREATE WIDTH HEIGHT BITSPERPIXEL)	[Function]
creates a color bitmap that is WIDTH pixels wide by HEIGHT pixels high allowing BITSPERPIXEL bits per pixel.  Currently any value of BITSPERPIXEL except one, four, eight, or NIL (defaults to one) causes an error. 
A four-bit-per-pixel color screen bitmap uses approximately 76K words of storage, and an eight-bit-per-pixel one uses approximately 153K words.  There is only one such bitmap.  The following function provides access to it.
(COLORSCREENBITMAP)	[Function]
returns the bitmap that is being or will be displayed on the color display.  This is NIL if the color display has never been turned on (see COLORDISPLAY below).
2
2

Screens, Screenpositions, and Screenregions
1

In addition to positions and regions, the user needs to be aware of screens, screenpositions, and screenregions in the presence of multiple screens.
Screens
1

SCREEN	[Datatype]
There are generally two screen datatype instances in existence when working with color.  This is because the user is attached to two displays, a black and white display and a color display.
(MAINSCREEN)	[Function]
returns the screen datatype instance that represents the black and white screen.  This will be something like {SCREEN}#74,24740.
(COLORSCREEN)	[Function]
returns the screen datatype instance that represents the color screen.  Screens appear as part of screenpositions and screenregions, serving as the extra information needed to make clear whether a particular position or region should be viewed as lying on the black and white display or the color display.
(SCREENBITMAP SCREEN)	[Function]
returns the bitmap destination of SCREEN.  If SCREEN=NIL, returns the black and white screen bitmap.
Screenpositions
1

SCREENPOSITION	[Record]
Somewhat like a position,  a screenposition denotes a point in an X,Y coordinate system on a particular screen.  Screenpositions have been defined according to the following record declaration:
(RECORD SCREENPOSITION (SCREEN . POSITION)
                     (SUBRECORD POSITION))
A SCREENPOSITION is an instance of a record with fields XCOORD, YCOORD, and SCREEN and is manipulated with the standard record package facilities.  For example, (create SCREENPOSITION XCOORD _ 10 YCOORD _ 20 SCREEN _ (COLORSCREEN)) creates a screenposition representing the point (10,20) on the color display.  The user can extract the position of a screenposition by fetching its POSITION.  For example, (fetch (SCREENPOSITION POSITION) of SP12).  
Screenregions
1

SCREENREGION	[Record]
Somewhat like a region, a screenregion denotes a rectangular area in a coordinate system.  Screenregions have been defined according to the following record declaration:
(RECORD SCREENREGION (SCREEN . REGION)
                     (SUBRECORD REGION))
Screenregions are characterized by the coordinates of their bottom left corner and their width and height.  A SCREENREGION is a record with fields LEFT, BOTTOM, WIDTH, HEIGHT, and SCREEN.  It can be manipulated with the standard record package facilities.  There are access functions for the REGION record that return the TOP and RIGHT of the region.  The user can extract the region of a screenregion by fetching its REGION.  For example, (fetch (SCREENREGION REGION) of SR8).
Screenposition and Screenregion Prompting
1

The following functions can be used by programs to allow the user to interactively specify screenpositions or screenregions on a display screen.
(GETSCREENPOSITION WINDOW CURSOR)  	[Function]
1

Similar to GETPOSITION.  Returns a SCREENPOSITION that is specified by the user.  GETSCREENPOSITION waits for the user to press and release the left button of the mouse and returns the cursor screenposition at the time of release.  If WINDOW is a WINDOW, the screenposition will be on the same screen as WINDOW  and in the coordinate system of WINDOW's display stream.  If WINDOW is NIL, the position will be in screen coordinates.
1

(GETBOXSCREENPOSITION BOXWIDTH BOXHEIGHT ORGX ORGY WINDOW PROMPTMSG)  	[Function]
1

Similar to GETBOXPOSITION.  Returns a SCREENPOSITION that is specified by the user.  Allows the user to position a "ghost" region of size BOXWIDTH by BOXHEIGHT on a screen, and returns the SCREENPOSITION of the lower left corner of the screenregion chosen.  A ghost region is locked to the cursor so that if the cursor is moved, the ghost region moves with it.  The user can change to another corner by holding down the right button.  With the right button down, the cursor can be moved across a screen or to other screens without effect on the ghost region frame.  When the right button is released, the mouse will snap to the nearest corner, which will then become locked to the cursor.  (The held corner can be changed after the left or middle button is down by holding both the original button and the right button down while the cursor is moved to the desired new corner, then letting up just the right button.)  When the left or middle button is pressed and released, the lower left corner of the screenregion chosen at the time of release is returned.  If WINDOW is a WINDOW, the screenposition will be on the same screen as WINDOW  and in the coordinate system of WINDOW's display stream.  If WINDOW is NIL, the position will be in screen coordinates.its lower left corner in screen coordinates.
1

(GETSCREENREGION MINWIDTH MINHEIGHT OLDREGION NEWREGIONFN NEWREGIONFNARG INITCORNERS)  	[Function]
1

Similar to GETREGION.  Returns a SCREENREGION that is specified by the user.  Lets the user specify a new screenregion and returns that screenregion.  GETSCREENREGION prompts for a screenregion by displaying a four-pronged box next to the cursor arrow at one corner of a "ghost" region: �����������$�$����.  If the user presses the left button, the corner of a "ghost" screenregion opposite the cursor is locked where it is.  Once one corner has been fixed, the ghost screenregion expands as the cursor moves.
To specify a screenregion:  (1) Move the ghost box so that the corner opposite the cursor is at one corner of the intended screenregion.  (2) Press the left button.  (3) Move the cursor to the screenposition of the opposite corner of the intended screenregion while holding down the left button.  (4) Release the left button.  
Before one corner has been fixed, one can switch the cursor to another corner of the ghost screenregion by holding down the right button.  With the right button down, the cursor changes to a "forceps" (9�)@9����p���������``) and the cursor can be moved across a screen or to other screens without effect on the ghost screenregion frame.  When the right button is released, the cursor will snap to the nearest corner of the ghost screenregion.
After one corner has been fixed, one can still switch to another corner.  To change to another corner, continue to hold down the left button and hold down the right button also.  With both buttons down, the cursor can be moved across a screen or to other screens without effect on the ghost screenregion frame.  When the right button is released, the cursor will snap to the nearest corner, which will become the moving corner.  In this way, the screenregion may be moved all over a screen and to other screens, before its size and screenposition is finalized.
The size of the initial ghost screenregion is controlled by the MINWIDTH, MINHEIGHT, OLDREGION, and INITCORNERS arguments.
1

(GETBOXSCREENREGION WIDTH HEIGHT ORGX ORGY WINDOW PROMPTMSG)  	[Function]
1

Similar to GETBOXREGION.  Returns a SCREENREGION that is specified by the user.  Performs the same prompting as GETBOXSCREENPOSITION and returns the SCREENREGION specified by the user instead of the SCREENPOSITION of its lower left corner.
1

2

Color Windows and Menus
1

The Xerox Lisp window system provides both interactive and programmatic constructs for creating, moving, reshaping, overlapping, and destroying windows in such a way that a program can use a window in a relatively transparent fashion (see ("Windows" . TERM)).  Menus are a special type of window provided by the window system, used for displaying a set of items to the user, and having the user select one using the mouse and cursor.  The menu facility also allows users to create and use menus in interactive programs (see ("Menus" . TERM)).  As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display.
(CREATEW REGION TITLE BORDERSIZE NOOPENFLG)  	[Function]
1

Creates a new window.  REGION indicates where and how large the window should be by specifying the exterior screenregion of the window.  In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of.  This problem is solved by allowing CREATEW to take screenregion arguments as REGION.  For example,
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
creates a window titled "FOO WINDOW" on the color screen.  To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression.  Note that it is still perfectly legal to pass in a REGION  that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW.  This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. 
When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor.  This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens.
1

(WINDOWPROP WINDOW PROP NEWVALUE)  	[NoSpread Function]
1

If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on.  If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error.  Any other PROP name is handled in the usual way.
1

(OPENWINDOWS SCREEN)  	[Function]
1

Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN).  If SCREEN=NIL, then SCREEN will default to the screen containing the cursor.  If SCREEN=T, then a list of all open windows on all screens is returned.
1

  
2

Color Fonts
1

The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color.
Color Font Creation
1

The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts.  This is made possible in some cases by there being new ways to call familiar  font  functions.
(FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)  	[Function]
1

In addition to creating black and white fonts, FONTCREATE can be used to create color fonts.  For example,
     (FONTCREATE 'GACHA 10
                                       '(BOLD REGULAR REGULAR YELLOW BLUE)
                                       0 '8DISPLAY)
will create an 8 bit per pixel font with blue letters on a yellow background.  The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE.  DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font.  A color font face is a 5 tuple,
     (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR)
whereas a black and white font face is just a 3 tuple,
     (WEIGHT SLOPE EXPANSION)
The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters.  Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation.  A color font face can also be represented as a LITATOM.  A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes.  For example,
     MRR-YELLOW-BLUE
     BOLD-YELLOW-RED
     ITALIC-90-200
     BRR-100-53
are acceptable color font faces.  Hence,
     (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY)
will create a color font.  LITATOM FACE arguments fall into one of the following patterns:
     wse                        wse-backcolor-forecolor
     STANDARD       STANDARD-backcolor-forecolor
     ITALIC                  ITALIC-backcolor-forecolor
     BOLD                    BOLD-backcolor-forecolor
     BOLDITALIC     BOLDITALIC-backcolor-forecolor
where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number.
1

(FONTPROP FONT PROP)  	[Function]
1

Returns the value of the PROP property of font FONT.  Besides black and white font properties, the following font properties are recognized:
	FORECOLOR	The color of the characters of the font, represented as a color number.  This is the color in which the characters of the font will print.
	BACKCOLOR	The color of the background of the characters of the font, represented as a color number.  This is the color in which the the background of characters of the font will print.  A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR.
Color Font Profiles
1


Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance.   The user can specify that different colors of fonts be used for different kinds of elements when printing in color.  A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example.  A FONTPROFILE such as
     ((DEFAULTFONT 1 (GACHA 10)
                   (GACHA 8)
                   (TERMINAL 8)
                   (4DISPLAY (GACHA 10 MRR-WHITE-RED))
                   (8DISPLAY (GACHA 10 MRR-WHITE-RED)))
      (BOLDFONT 2 (HELVETICA 10 BRR)
                (HELVETICA 8 BRR)
                (MODERN 8 BRR)
                (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))
                (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)))
      (LITTLEFONT 3 (HELVETICA 8)
                  (HELVETICA 6 MIR)
                  (MODERN 8 MIR)
                  (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))
                  (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)))
      (BIGFONT 4 (HELVETICA 12 BRR)
               (HELVETICA 10 BRR)
               (MODERN 10 BRR)
               (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))
               (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)))
      (USERFONT BOLDFONT)
      (COMMENTFONT LITTLEFONT)
      (LAMBDAFONT BIGFONT)
      (SYSTEMFONT)
      (CLISPFONT BOLDFONT)
      ...)
would have comments print in green and clisp words print in blue while ordinairy atoms would print in red.
Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set.
The user should indicate what  font is to be used for each font class by calling the function FONTPROFILE:
(FONTPROFILE PROFILE)  	[Function]
1

Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts.  Each element of PROFILE is a list of the form:
(FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1)  ... (OTHERDEVICEn OTHERFONTn))
FONTCLASS is the font class name and FONT# is the font number for that class.  DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively.  The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color  font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED).  
1

FONTPROFILE  	[Variable]
1

This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE.  Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 
1

2

Using Color
1

The current color implementation allows display streams to operate on color bitmaps.  The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function.
(DSPCOLOR COLOR STREAM)	[Function]
sets the foreground color of a stream.  It returns the previous foreground color.  If COLOR is NIL, it returns the current foreground color without changing anything.  The default foreground color is MINIMUMCOLOR=0,  which is white in the default color maps.
(DSPBACKCOLOR COLOR STREAM) 	 [Function]
sets the background color of a stream.   It returns the previous background color.  If COLOR is NIL, it returns the current background color without changing anything.  The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps.
The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream.  Following are some notes about them.
2

BITBLTing in Color
1


If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level.  Thus painting color 3 onto color 10 results in color 11.
If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR.  BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy.
If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color.  Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT  NIL  NIL  NIL  COLORSTR  50  75  100  200 'TEXTURE  'REPLACE  'BLUE).
2

Drawing Curves and Lines in Color
1

For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color.  A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR).  Also, a brush can be a bitmap (which can be a color bitmap).
Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap.
(DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION 
                          STREAM COLOR)	[Function]
(DRAWTO X Y WIDTH OPERATION STREAM COLOR)	[Function]
(RELDRAWTO X Y WIDTH OPERATION 
                                 STREAM COLOR)	[Function]
(DRAWBETWEEN POS1 POS2  WIDTH OPERATION
                                         STREAM COLOR)	[Function]
If the COLOR argument is NIL, the DSPCOLOR of the stream is used.
2

Printing in Color
1

Printing only works in REPLACE mode.  The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with.  
Example of printing to an 8bpp color screen:
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
(DSPFONT (FONTCREATE 'GACHA
                                                          10
                                                           'MRR-YELLOW-GREEN
                                                           0
                                                            '8DISPLAY)
                        FOO)
(PRINT 'HELLO FOO)	; will print in green against a yellow background.
2

Operating the Cursor on the Color Screen
1

The cursor can be moved to the color screen.  The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN.
(CURSORPOSITION NEWPOSITION - -)  	[Function]
1

NEWPOSITION can be a position or a screenposition.
(CURSORSCREEN SCREEN XCOORD YCOORD)  	[Function]
1

Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD.  SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN).
While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor.  It is automatically taken down whenever an operation is performed that changes any bits on the color screen.  The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen.  While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time.
  
2

Miscellaneous Color Functions
1

(COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL)	[Function]
creates a color bitmap from a black and white bitmap.  The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero.  This provides a way of producing a color bitmap from a black and white bitmap.
(UNCOLORIZEBITMAP BITMAP COLORMAP)	[Function]
creates a black and white bitmap from a color bitmap.
(SHOWCOLORTESTPATTERN BARSIZE)	[Function]
displays a pattern of colors on the color display.  This is useful when editing a color map.  The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen.  Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row.  The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers.  The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color���%�about 20). 
(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL (
PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE 
REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (
54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 
618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD
 LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT 
MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) 
NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) (
PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) 
CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)
 FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (
HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))))7��� ���8��� ���T(���1����(���)KK�T/K���T(���5��� n�T/����T/����T/����T/����T/����T/�2�T/��T/��T/��T.����.����/��T/�2�T.����.����<�PAGEHEADING	VERSOHEAD<�PAGEHEADING	RECTOHEAD;�PAGEHEADINGFOOTINGV;�PAGEHEADINGFOOTINGR	?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8))
+MODERNMODERNMODERNMODERNMODERN
+MODERN
+MODERN
+MODERN
+HRULE.GETFNMODERN
+		HRULE.GETFNMODERN
+			HRULE.GETFNMODERN
+			HRULE.GETFNMODERN
+	
HRULE.GETFNMODERNHRULE.GETFNMODERN
HRULE.GETFNMODERN�	�	�	�	f	�	�	f	
+�	HRULE.GETFNMODERN.HRULE.GETFNMODERN�		@	

+			W	�	(			"	�	=	HRULE.GETFNMODERN	HRULE.GETFNMODERN�	�		`		HRULE.GETFNMODERN	�	
+	]	
+	>	�		&										HRULE.GETFNMODERN	�	
+	�	
			?			=					�				"					"	HRULE.GETFNMODERNHRULE.GETFNMODERNy		D	+	q		B	-		i	(		_	

		L			*		X	=	�				*	�	
		?			N				�	HRULE.GETFNMODERN_		
+8	-			
+		Z		
+&	8	,			S						=				m	
+	
+)	
+	
+	
	
+	
	
+	/		�	�	�	;	�	�	HRULE.GETFNMODERNHRULE.GETFNMODERN�	
				v	4	
					)	E	�		�	HRULE.GETFNMODERNHRULE.GETFN,HRULE.GETFNMODERN�	HRULE.GETFNMODERN	�		�	
	2		"		1	HRULE.GETFNMODERN
+	�	+	+	�	
HRULE.GETFNMODERN
+	�	'	)	�	)HRULE.GETFNMODERN�	
	HRULE.GETFNMODERN
+	�	?	"		4	HRULE.GETFNMODERN
+	-	HRULE.GETFNMODERN
+	�			�	?	"		a	HRULE.GETFNMODERN
+	C	HRULE.GETFNMODERN
+		(BMOBJ.GETFN3�	H	�	,BMOBJ.GETFN3�	1	@							HRULE.GETFNMODERN
+	'	HRULE.GETFNMODERN
+	�	HRULE.GETFNMODERN
+	HRULE.GETFNMODERNHRULE.GETFNMODERN�	).  Menus are a special type of window provided by the window system, used for displaying a set of items to the user, and having the user select one using the mouse and cursor.  The menu facility also allows users to create and use menus in interactive programs (see ("Menus" . TERM)).  As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display.
(CREATEW REGION TITLE BORDERSIZE NOOPENFLG)  	[Function]
1

Creates a new window.  REGION indicates where and how large the window should be by specifying the exterior screenregion of the window.  In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of.  This problem is solved by allowing CREATEW to take screenregion arguments as REGION.  For example,
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
creates a window titled "FOO WINDOW" on the color screen.  To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression.  Note that it is still perfectly legal to pass in a REGION  that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW.  This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. 
When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor.  This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens.
1

(WINDOWPROP WINDOW PROP NEWVALUE)  	[NoSpread Function]
1

If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on.  If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error.  Any other PROP name is handled in the usual way.
1

(OPENWINDOWS SCREEN)  	[Function]
1

Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN).  If SCREEN=NIL, then SCREEN will default to the screen containing the cursor.  If SCREEN=T, then a list of all open windows on all screens is returned.
1

  
2

Color Fonts
1

The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color.
Color Font Creation
1

The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts.  This is made possible in some cases by there being new ways to call familiar  font  functions.
(FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)  	[Function]
1

In addition to creating black and white fonts, FONTCREATE can be used to create color fonts.  For example,
     (FONTCREATE 'GACHA 10
                                       '(BOLD REGULAR REGULAR YELLOW BLUE)
                                       0 '8DISPLAY)
will create an 8 bit per pixel font with blue letters on a yellow background.  The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE.  DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font.  A color font face is a 5 tuple,
     (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR)
whereas a black and white font face is just a 3 tuple,
     (WEIGHT SLOPE EXPANSION)
The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters.  Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation.  A color font face can also be represented as a LITATOM.  A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes.  For example,
     MRR-YELLOW-BLUE
     BOLD-YELLOW-RED
     ITALIC-90-200
     BRR-100-53
are acceptable color font faces.  Hence,
     (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY)
will create a color font.  LITATOM FACE arguments fall into one of the following patterns:
     wse                        wse-backcolor-forecolor
     STANDARD       STANDARD-backcolor-forecolor
     ITALIC                  ITALIC-backcolor-forecolor
     BOLD                    BOLD-backcolor-forecolor
     BOLDITALIC     BOLDITALIC-backcolor-forecolor
where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number.
1

(FONTPROP FONT PROP)  	[Function]
1

Returns the value of the PROP property of font FONT.  Besides black and white font properties, the following font properties are recognized:
	FORECOLOR	The color of the characters of the font, represented as a color number.  This is the color in which the characters of the font will print.
	BACKCOLOR	The color of the background of the characters of the font, represented as a color number.  This is the color in which the the background of characters of the font will print.  A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR.
Color Font Profiles
1


Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance.   The user can specify that different colors of fonts be used for different kinds of elements when printing in color.  A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example.  A FONTPROFILE such as
     ((DEFAULTFONT 1 (GACHA 10)
                   (GACHA 8)
                   (TERMINAL 8)
                   (4DISPLAY (GACHA 10 MRR-WHITE-RED))
                   (8DISPLAY (GACHA 10 MRR-WHITE-RED)))
      (BOLDFONT 2 (HELVETICA 10 BRR)
                (HELVETICA 8 BRR)
                (MODERN 8 BRR)
                (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))
                (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)))
      (LITTLEFONT 3 (HELVETICA 8)
                  (HELVETICA 6 MIR)
                  (MODERN 8 MIR)
                  (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))
                  (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)))
      (BIGFONT 4 (HELVETICA 12 BRR)
               (HELVETICA 10 BRR)
               (MODERN 10 BRR)
               (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))
               (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)))
      (USERFONT BOLDFONT)
      (COMMENTFONT LITTLEFONT)
      (LAMBDAFONT BIGFONT)
      (SYSTEMFONT)
      (CLISPFONT BOLDFONT)
      ...)
would have comments print in green and clisp words print in blue while ordinairy atoms would print in red.
Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set.
The user should indicate what  font is to be used for each font class by calling the function FONTPROFILE:
(FONTPROFILE PROFILE)  	[Function]
1

Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts.  Each element of PROFILE is a list of the form:
(FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1)  ... (OTHERDEVICEn OTHERFONTn))
FONTCLASS is the font class name and FONT# is the font number for that class.  DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively.  The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color  font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED).  
1

FONTPROFILE  	[Variable]
1

This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE.  Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 
1

2

Using Color
1

The current color implementation allows display streams to operate on color bitmaps.  The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function.
(DSPCOLOR COLOR STREAM)	[Function]
sets the foreground color of a stream.  It returns the previous foreground color.  If COLOR is NIL, it returns the current foreground color without changing anything.  The default foreground color is MINIMUMCOLOR=0,  which is white in the default color maps.
(DSPBACKCOLOR COLOR STREAM) 	 [Function]
sets the background color of a stream.   It returns the previous background color.  If COLOR is NIL, it returns the current background color without changing anything.  The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps.
The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream.  Following are some notes about them.
2

BITBLTing in Color
1


If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level.  Thus painting color 3 onto color 10 results in color 11.
If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR.  BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy.
If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color.  Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT  NIL  NIL  NIL  COLORSTR  50  75  100  200 'TEXTURE  'REPLACE  'BLUE).
2

Drawing Curves and Lines in Color
1

For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color.  A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR).  Also, a brush can be a bitmap (which can be a color bitmap).
Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap.
(DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION 
                          STREAM COLOR)	[Function]
(DRAWTO X Y WIDTH OPERATION STREAM COLOR)	[Function]
(RELDRAWTO X Y WIDTH OPERATION 
                                 STREAM COLOR)	[Function]
(DRAWBETWEEN POS1 POS2  WIDTH OPERATION
                                         STREAM COLOR)	[Function]
If the COLOR argument is NIL, the DSPCOLOR of the stream is used.
2

Printing in Color
1

Printing only works in REPLACE mode.  The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with.  
Example of printing to an 8bpp color screen:
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
(DSPFONT (FONTCREATE 'GACHA
                                                          10
                                                           'MRR-YELLOW-GREEN
                                                           0
                                                            '8DISPLAY)
                        FOO)
(PRINT 'HELLO FOO)	; will print in green against a yellow background.
2

Operating the Cursor on the Color Screen
1

The cursor can be moved to the color screen.  The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN.
(CURSORPOSITION NEWPOSITION - -)  	[Function]
1

NEWPOSITION can be a position or a screenposition.
(CURSORSCREEN SCREEN XCOORD YCOORD)  	[Function]
1

Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD.  SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN).
While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor.  It is automatically taken down whenever an operation is performed that changes any bits on the color screen.  The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen.  While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time.
  
2

Miscellaneous Color Functions
1

(COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL)	[Function]
creates a color bitmap from a black and white bitmap.  The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero.  This provides a way of producing a color bitmap from a black and white bitmap.
(UNCOLORIZEBITMAP BITMAP COLORMAP)	[Function]
creates a black and white bitmap from a color bitmap.
(SHOWCOLORTESTPATTERN BARSIZE)	[Function]
displays a pattern of colors on the color display.  This is useful when editing a color map.  The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen.  Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row.  The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers.  The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color���%�about 20). 
(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL (
PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE 
REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (
54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 
618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD
 LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT 
MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) 
NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) (
PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) 
CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)
 FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (
HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))))7��� ���8��� ���T(���1����(���)KK�T/K���T(���5��� n�T/����T/����T/����T/����T/����T/�2�T/��T/��T/��T.����.����/��T/�2�T.����.����<�PAGEHEADING	VERSOHEAD<�PAGEHEADING	RECTOHEAD;�PAGEHEADINGFOOTINGV;�PAGEHEADINGFOOTINGR	?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8))
+MODERNMODERNMODERNMODERNMODERN
+MODERN
+MODERN
+MODERN
+HRULE.GETFNMODERN
+		HRULE.GETFNMODERN
+			HRULE.GETFNMODERN
+			HRULE.GETFNMODERN
+	
HRULE.GETFNMODERNHRULE.GETFNMODERN
HRULE.GETFNMODERN�	�	�	�	f	�	�	f	
+�	HRULE.GETFNMODERN.HRULE.GETFNMODERN�		@	

+			W	�	(			"	�	=	HRULE.GETFNMODERN	HRULE.GETFNMODERN�	�		`		HRULE.GETFNMODERN	�	
+	]	
+	>	�		&										HRULE.GETFNMODERN	�	
+	�	
			?			=					�				"					"	HRULE.GETFNMODERNHRULE.GETFNMODERNy		D	+	q		B	-		i	(		_	

		L			*		X	=	�				*	�	
		?			N				�	HRULE.GETFNMODERN_		
+8	-			
+		Z		
+&	8	,			S						=				m	
+	
+)	
+	
+	
	
+	
	
+	/		�	�	�	;	�	�	HRULE.GETFNMODERNHRULE.GETFNMODERN�	
				v	4	
					)	E	�		�	HRULE.GETFNMODERNHRULE.GETFN,HRULE.GETFNMODERN�	HRULE.GETFNMODERN	�		�	
	2		"		1	HRULE.GETFNMODERN
+	�	+	+	�	
HRULE.GETFNMODERN
+	�	'	)	�	)HRULE.GETFNMODERN�	
	HRULE.GETFNMODERN
+	�	?	"		4	HRULE.GETFNMODERN
+	-	HRULE.GETFNMODERN
+	�			�	?	"		a	HRULE.GETFNMODERN
+	C	HRULE.GETFNMODERN
+		(BMOBJ.GETFN3�	H	�	,BMOBJ.GETFN3�	1	@							HRULE.GETFNMODERN
+	'	HRULE.GETFNMODERN
+	�	HRULE.GETFNMODERN
+	HRULE.GETFNMODERNHRULE.GETFNMODERN�	IRM.GET.CREF	).  As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display.
(CREATEW REGION TITLE BORDERSIZE NOOPENFLG)  	[Function]
1

Creates a new window.  REGION indicates where and how large the window should be by specifying the exterior screenregion of the window.  In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of.  This problem is solved by allowing CREATEW to take screenregion arguments as REGION.  For example,
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
creates a window titled "FOO WINDOW" on the color screen.  To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression.  Note that it is still perfectly legal to pass in a REGION  that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW.  This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. 
When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor.  This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens.
1

(WINDOWPROP WINDOW PROP NEWVALUE)  	[NoSpread Function]
1

If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on.  If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error.  Any other PROP name is handled in the usual way.
1

(OPENWINDOWS SCREEN)  	[Function]
1

Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN).  If SCREEN=NIL, then SCREEN will default to the screen containing the cursor.  If SCREEN=T, then a list of all open windows on all screens is returned.
1

  
2

Color Fonts
1

The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color.
Color Font Creation
1

The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts.  This is made possible in some cases by there being new ways to call familiar  font  functions.
(FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)  	[Function]
1

In addition to creating black and white fonts, FONTCREATE can be used to create color fonts.  For example,
     (FONTCREATE 'GACHA 10
                                       '(BOLD REGULAR REGULAR YELLOW BLUE)
                                       0 '8DISPLAY)
will create an 8 bit per pixel font with blue letters on a yellow background.  The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE.  DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font.  A color font face is a 5 tuple,
     (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR)
whereas a black and white font face is just a 3 tuple,
     (WEIGHT SLOPE EXPANSION)
The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters.  Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation.  A color font face can also be represented as a LITATOM.  A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes.  For example,
     MRR-YELLOW-BLUE
     BOLD-YELLOW-RED
     ITALIC-90-200
     BRR-100-53
are acceptable color font faces.  Hence,
     (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY)
will create a color font.  LITATOM FACE arguments fall into one of the following patterns:
     wse                        wse-backcolor-forecolor
     STANDARD       STANDARD-backcolor-forecolor
     ITALIC                  ITALIC-backcolor-forecolor
     BOLD                    BOLD-backcolor-forecolor
     BOLDITALIC     BOLDITALIC-backcolor-forecolor
where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number.
1

(FONTPROP FONT PROP)  	[Function]
1

Returns the value of the PROP property of font FONT.  Besides black and white font properties, the following font properties are recognized:
	FORECOLOR	The color of the characters of the font, represented as a color number.  This is the color in which the characters of the font will print.
	BACKCOLOR	The color of the background of the characters of the font, represented as a color number.  This is the color in which the the background of characters of the font will print.  A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR.
Color Font Profiles
1


Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance.   The user can specify that different colors of fonts be used for different kinds of elements when printing in color.  A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example.  A FONTPROFILE such as
     ((DEFAULTFONT 1 (GACHA 10)
                   (GACHA 8)
                   (TERMINAL 8)
                   (4DISPLAY (GACHA 10 MRR-WHITE-RED))
                   (8DISPLAY (GACHA 10 MRR-WHITE-RED)))
      (BOLDFONT 2 (HELVETICA 10 BRR)
                (HELVETICA 8 BRR)
                (MODERN 8 BRR)
                (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))
                (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)))
      (LITTLEFONT 3 (HELVETICA 8)
                  (HELVETICA 6 MIR)
                  (MODERN 8 MIR)
                  (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))
                  (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)))
      (BIGFONT 4 (HELVETICA 12 BRR)
               (HELVETICA 10 BRR)
               (MODERN 10 BRR)
               (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))
               (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)))
      (USERFONT BOLDFONT)
      (COMMENTFONT LITTLEFONT)
      (LAMBDAFONT BIGFONT)
      (SYSTEMFONT)
      (CLISPFONT BOLDFONT)
      ...)
would have comments print in green and clisp words print in blue while ordinairy atoms would print in red.
Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set.
The user should indicate what  font is to be used for each font class by calling the function FONTPROFILE:
(FONTPROFILE PROFILE)  	[Function]
1

Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts.  Each element of PROFILE is a list of the form:
(FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1)  ... (OTHERDEVICEn OTHERFONTn))
FONTCLASS is the font class name and FONT# is the font number for that class.  DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively.  The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color  font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED).  
1

FONTPROFILE  	[Variable]
1

This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE.  Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 
1

2

Using Color
1

The current color implementation allows display streams to operate on color bitmaps.  The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function.
(DSPCOLOR COLOR STREAM)	[Function]
sets the foreground color of a stream.  It returns the previous foreground color.  If COLOR is NIL, it returns the current foreground color without changing anything.  The default foreground color is MINIMUMCOLOR=0,  which is white in the default color maps.
(DSPBACKCOLOR COLOR STREAM) 	 [Function]
sets the background color of a stream.   It returns the previous background color.  If COLOR is NIL, it returns the current background color without changing anything.  The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps.
The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream.  Following are some notes about them.
2

BITBLTing in Color
1


If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level.  Thus painting color 3 onto color 10 results in color 11.
If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR.  BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy.
If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color.  Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT  NIL  NIL  NIL  COLORSTR  50  75  100  200 'TEXTURE  'REPLACE  'BLUE).
2

Drawing Curves and Lines in Color
1

For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color.  A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR).  Also, a brush can be a bitmap (which can be a color bitmap).
Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap.
(DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION 
                          STREAM COLOR)	[Function]
(DRAWTO X Y WIDTH OPERATION STREAM COLOR)	[Function]
(RELDRAWTO X Y WIDTH OPERATION 
                                 STREAM COLOR)	[Function]
(DRAWBETWEEN POS1 POS2  WIDTH OPERATION
                                         STREAM COLOR)	[Function]
If the COLOR argument is NIL, the DSPCOLOR of the stream is used.
2

Printing in Color
1

Printing only works in REPLACE mode.  The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with.  
Example of printing to an 8bpp color screen:
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
(DSPFONT (FONTCREATE 'GACHA
                                                          10
                                                           'MRR-YELLOW-GREEN
                                                           0
                                                            '8DISPLAY)
                        FOO)
(PRINT 'HELLO FOO)	; will print in green against a yellow background.
2

Operating the Cursor on the Color Screen
1

The cursor can be moved to the color screen.  The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN.
(CURSORPOSITION NEWPOSITION - -)  	[Function]
1

NEWPOSITION can be a position or a screenposition.
(CURSORSCREEN SCREEN XCOORD YCOORD)  	[Function]
1

Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD.  SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN).
While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor.  It is automatically taken down whenever an operation is performed that changes any bits on the color screen.  The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen.  While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time.
  
2

Miscellaneous Color Functions
1

(COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL)	[Function]
creates a color bitmap from a black and white bitmap.  The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero.  This provides a way of producing a color bitmap from a black and white bitmap.
(UNCOLORIZEBITMAP BITMAP COLORMAP)	[Function]
creates a black and white bitmap from a color bitmap.
(SHOWCOLORTESTPATTERN BARSIZE)	[Function]
displays a pattern of colors on the color display.  This is useful when editing a color map.  The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen.  Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row.  The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers.  The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color���%�about 20). 
(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))));��� ���<��� ���T,���5����,���-KK�T3K���T,���9��� n�T3����T3����T3����T3����T3����T3�2�T3��T3��T3��T2����2����3��T3�2�T2����2����@�PAGEHEADING	VERSOHEAD@�PAGEHEADING	RECTOHEAD?�PAGEHEADINGFOOTINGV?�PAGEHEADINGFOOTINGR	?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8))
+MODERNMODERNMODERNMODERNMODERN
+MODERN
+MODERN
+MODERN
+HRULE.GETFNMODERN
+		HRULE.GETFNMODERN
+			HRULE.GETFNMODERN
+			HRULE.GETFNMODERN
+	
HRULE.GETFNMODERNHRULE.GETFNMODERN
HRULE.GETFNMODERN	�	�	�	K	f	�	�	HRULE.GETFNMODERN'HRULE.GETFNMODERN
+	@	�	�	HRULE.GETFNMODERN.HRULE.GETFNMODERN�		@	

+			W	�	(			"	�	=	HRULE.GETFNMODERN	HRULE.GETFNMODERN�	
+�	�	�		`		HRULE.GETFNMODERN	�	
+	]	
+	>	�		&										HRULE.GETFNMODERN	�	
+	�	
			?			=					�				"					"	HRULE.GETFNMODERNHRULE.GETFNMODERNy		D	+	q		B	-		i	(		_	

		L			*		X	=	�				*	�	
		?			N				�	HRULE.GETFNMODERN_		
+8	-			
+		Z		
+&	8	,			S						=				m	
+	
+)	
+	
+	
	
+	
	
+	/		�	�	�	;	�	�	HRULE.GETFNMODERNHRULE.GETFNMODERN�	
				v	4	
					)	E	�		�	HRULE.GETFNMODERNHRULE.GETFN,HRULE.GETFNMODERN�	HRULE.GETFNMODERN	�		�	
	2		"		1	HRULE.GETFNMODERN
+	�	+	+	�	
HRULE.GETFNMODERN
+	�	'	)	�	)HRULE.GETFNMODERN�	
	HRULE.GETFNMODERN
+	�	?	"		4	HRULE.GETFNMODERN
+	-	HRULE.GETFNMODERN
+	�			�	?	"		a	HRULE.GETFNMODERN
+	C	HRULE.GETFNMODERN
+		(BMOBJ.GETFN3�	H	�	,BMOBJ.GETFN3�	1	@							HRULE.GETFNMODERN
+	'	HRULE.GETFNMODERN
+	�	HRULE.GETFNMODERN
+	HRULE.GETFNMODERNHRULE.GETFNMODERN�	a).  Menus are a special type of window provided by the window system, used for displaying a set of items to the user, and having the user select one using the mouse and cursor.  The menu facility also allows users to create and use menus in interactive programs (see ("Menus" . TERM)).  As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display.
(CREATEW REGION TITLE BORDERSIZE NOOPENFLG)  	[Function]
1

Creates a new window.  REGION indicates where and how large the window should be by specifying the exterior screenregion of the window.  In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of.  This problem is solved by allowing CREATEW to take screenregion arguments as REGION.  For example,
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
creates a window titled "FOO WINDOW" on the color screen.  To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression.  Note that it is still perfectly legal to pass in a REGION  that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW.  This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. 
When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor.  This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens.
1

(WINDOWPROP WINDOW PROP NEWVALUE)  	[NoSpread Function]
1

If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on.  If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error.  Any other PROP name is handled in the usual way.
1

(OPENWINDOWS SCREEN)  	[Function]
1

Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN).  If SCREEN=NIL, then SCREEN will default to the screen containing the cursor.  If SCREEN=T, then a list of all open windows on all screens is returned.
1

  
2

Color Fonts
1

The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color.
Color Font Creation
1

The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts.  This is made possible in some cases by there being new ways to call familiar  font  functions.
(FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)  	[Function]
1

In addition to creating black and white fonts, FONTCREATE can be used to create color fonts.  For example,
     (FONTCREATE 'GACHA 10
                                       '(BOLD REGULAR REGULAR YELLOW BLUE)
                                       0 '8DISPLAY)
will create an 8 bit per pixel font with blue letters on a yellow background.  The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE.  DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font.  A color font face is a 5 tuple,
     (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR)
whereas a black and white font face is just a 3 tuple,
     (WEIGHT SLOPE EXPANSION)
The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters.  Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation.  A color font face can also be represented as a LITATOM.  A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes.  For example,
     MRR-YELLOW-BLUE
     BOLD-YELLOW-RED
     ITALIC-90-200
     BRR-100-53
are acceptable color font faces.  Hence,
     (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY)
will create a color font.  LITATOM FACE arguments fall into one of the following patterns:
     wse                        wse-backcolor-forecolor
     STANDARD       STANDARD-backcolor-forecolor
     ITALIC                  ITALIC-backcolor-forecolor
     BOLD                    BOLD-backcolor-forecolor
     BOLDITALIC     BOLDITALIC-backcolor-forecolor
where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number.
1

(FONTPROP FONT PROP)  	[Function]
1

Returns the value of the PROP property of font FONT.  Besides black and white font properties, the following font properties are recognized:
	FORECOLOR	The color of the characters of the font, represented as a color number.  This is the color in which the characters of the font will print.
	BACKCOLOR	The color of the background of the characters of the font, represented as a color number.  This is the color in which the the background of characters of the font will print.  A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR.
Color Font Profiles
1


Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance.   The user can specify that different colors of fonts be used for different kinds of elements when printing in color.  A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example.  A FONTPROFILE such as
     ((DEFAULTFONT 1 (GACHA 10)
                   (GACHA 8)
                   (TERMINAL 8)
                   (4DISPLAY (GACHA 10 MRR-WHITE-RED))
                   (8DISPLAY (GACHA 10 MRR-WHITE-RED)))
      (BOLDFONT 2 (HELVETICA 10 BRR)
                (HELVETICA 8 BRR)
                (MODERN 8 BRR)
                (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))
                (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)))
      (LITTLEFONT 3 (HELVETICA 8)
                  (HELVETICA 6 MIR)
                  (MODERN 8 MIR)
                  (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))
                  (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)))
      (BIGFONT 4 (HELVETICA 12 BRR)
               (HELVETICA 10 BRR)
               (MODERN 10 BRR)
               (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))
               (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)))
      (USERFONT BOLDFONT)
      (COMMENTFONT LITTLEFONT)
      (LAMBDAFONT BIGFONT)
      (SYSTEMFONT)
      (CLISPFONT BOLDFONT)
      ...)
would have comments print in green and clisp words print in blue while ordinairy atoms would print in red.
Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set.
The user should indicate what  font is to be used for each font class by calling the function FONTPROFILE:
(FONTPROFILE PROFILE)  	[Function]
1

Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts.  Each element of PROFILE is a list of the form:
(FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1)  ... (OTHERDEVICEn OTHERFONTn))
FONTCLASS is the font class name and FONT# is the font number for that class.  DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively.  The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color  font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED).  
1

FONTPROFILE  	[Variable]
1

This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE.  Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 
1

2

Using Color
1

The current color implementation allows display streams to operate on color bitmaps.  The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function.
(DSPCOLOR COLOR STREAM)	[Function]
sets the foreground color of a stream.  It returns the previous foreground color.  If COLOR is NIL, it returns the current foreground color without changing anything.  The default foreground color is MINIMUMCOLOR=0,  which is white in the default color maps.
(DSPBACKCOLOR COLOR STREAM) 	 [Function]
sets the background color of a stream.   It returns the previous background color.  If COLOR is NIL, it returns the current background color without changing anything.  The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps.
The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream.  Following are some notes about them.
2

BITBLTing in Color
1


If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level.  Thus painting color 3 onto color 10 results in color 11.
If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR.  BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy.
If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color.  Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT  NIL  NIL  NIL  COLORSTR  50  75  100  200 'TEXTURE  'REPLACE  'BLUE).
2

Drawing Curves and Lines in Color
1

For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color.  A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR).  Also, a brush can be a bitmap (which can be a color bitmap).
Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap.
(DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION 
                          STREAM COLOR)	[Function]
(DRAWTO X Y WIDTH OPERATION STREAM COLOR)	[Function]
(RELDRAWTO X Y WIDTH OPERATION 
                                 STREAM COLOR)	[Function]
(DRAWBETWEEN POS1 POS2  WIDTH OPERATION
                                         STREAM COLOR)	[Function]
If the COLOR argument is NIL, the DSPCOLOR of the stream is used.
2

Printing in Color
1

Printing only works in REPLACE mode.  The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with.  
Example of printing to an 8bpp color screen:
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
(DSPFONT (FONTCREATE 'GACHA
                                                          10
                                                           'MRR-YELLOW-GREEN
                                                           0
                                                            '8DISPLAY)
                        FOO)
(PRINT 'HELLO FOO)	; will print in green against a yellow background.
2

Operating the Cursor on the Color Screen
1

The cursor can be moved to the color screen.  The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN.
(CURSORPOSITION NEWPOSITION - -)  	[Function]
1

NEWPOSITION can be a position or a screenposition.
(CURSORSCREEN SCREEN XCOORD YCOORD)  	[Function]
1

Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD.  SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN).
While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor.  It is automatically taken down whenever an operation is performed that changes any bits on the color screen.  The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen.  While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time.
  
2

Miscellaneous Color Functions
1

(COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL)	[Function]
creates a color bitmap from a black and white bitmap.  The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero.  This provides a way of producing a color bitmap from a black and white bitmap.
(UNCOLORIZEBITMAP BITMAP COLORMAP)	[Function]
creates a black and white bitmap from a color bitmap.
(SHOWCOLORTESTPATTERN BARSIZE)	[Function]
displays a pattern of colors on the color display.  This is useful when editing a color map.  The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen.  Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row.  The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers.  The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color���%�about 20). 
(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL (
PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE 
REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (
54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 
618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD
 LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT 
MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) 
NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) (
PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) 
CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)
 FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (
HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))))7��� ���8��� ���T(���1����(���)KK�T/K���T(���5��� n�T/����T/����T/����T/����T/����T/�2�T/��T/��T/��T.����.����/��T/�2�T.����.����<�PAGEHEADING	VERSOHEAD<�PAGEHEADING	RECTOHEAD;�PAGEHEADINGFOOTINGV;�PAGEHEADINGFOOTINGR	?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8))
+MODERNMODERNMODERNMODERNMODERN
+MODERN
+MODERN
+MODERN
+HRULE.GETFNMODERN
+		HRULE.GETFNMODERN
+			HRULE.GETFNMODERN
+			HRULE.GETFNMODERN
+	
HRULE.GETFNMODERNHRULE.GETFNMODERN
HRULE.GETFNMODERN�	�	�	�	f	�	�	f	
+�	HRULE.GETFNMODERN.HRULE.GETFNMODERN�		@	

+			W	�	(			"	�	=	HRULE.GETFNMODERN	HRULE.GETFNMODERN�	�		`		HRULE.GETFNMODERN	�	
+	]	
+	>	�		&										HRULE.GETFNMODERN	�	
+	�	
			?			=					�				"					"	HRULE.GETFNMODERNHRULE.GETFNMODERNy		D	+	q		B	-		i	(		_	

		L			*		X	=	�				*	�	
		?			N				�	HRULE.GETFNMODERN_		
+8	-			
+		Z		
+&	8	,			S						=				m	
+	
+)	
+	
+	
	
+	
	
+	/		�	�	�	;	�	�	HRULE.GETFNMODERNHRULE.GETFNMODERN�	
				v	4	
					)	E	�		�	HRULE.GETFNMODERNHRULE.GETFN,HRULE.GETFNMODERN�	HRULE.GETFNMODERN	�		�	
	2		"		1	HRULE.GETFNMODERN
+	�	+	+	�	
HRULE.GETFNMODERN
+	�	'	)	�	)HRULE.GETFNMODERN�	
	HRULE.GETFNMODERN
+	�	?	"		4	HRULE.GETFNMODERN
+	-	HRULE.GETFNMODERN
+	�			�	?	"		a	HRULE.GETFNMODERN
+	C	HRULE.GETFNMODERN
+		(BMOBJ.GETFN3�	H	�	,BMOBJ.GETFN3�	1	@							HRULE.GETFNMODERN
+	'	HRULE.GETFNMODERN
+	�	HRULE.GETFNMODERN
+	HRULE.GETFNMODERNHRULE.GETFNMODERN�	IRM.GET.CREF	).  As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display.
(CREATEW REGION TITLE BORDERSIZE NOOPENFLG)  	[Function]
1

Creates a new window.  REGION indicates where and how large the window should be by specifying the exterior screenregion of the window.  In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of.  This problem is solved by allowing CREATEW to take screenregion arguments as REGION.  For example,
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
creates a window titled "FOO WINDOW" on the color screen.  To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression.  Note that it is still perfectly legal to pass in a REGION  that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW.  This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. 
When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor.  This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens.
1

(WINDOWPROP WINDOW PROP NEWVALUE)  	[NoSpread Function]
1

If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on.  If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error.  Any other PROP name is handled in the usual way.
1

(OPENWINDOWS SCREEN)  	[Function]
1

Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN).  If SCREEN=NIL, then SCREEN will default to the screen containing the cursor.  If SCREEN=T, then a list of all open windows on all screens is returned.
1

  
2

Color Fonts
1

The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color.
Color Font Creation
1

The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts.  This is made possible in some cases by there being new ways to call familiar  font  functions.
(FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)  	[Function]
1

In addition to creating black and white fonts, FONTCREATE can be used to create color fonts.  For example,
     (FONTCREATE 'GACHA 10
                                       '(BOLD REGULAR REGULAR YELLOW BLUE)
                                       0 '8DISPLAY)
will create an 8 bit per pixel font with blue letters on a yellow background.  The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE.  DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font.  A color font face is a 5 tuple,
     (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR)
whereas a black and white font face is just a 3 tuple,
     (WEIGHT SLOPE EXPANSION)
The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters.  Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation.  A color font face can also be represented as a LITATOM.  A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes.  For example,
     MRR-YELLOW-BLUE
     BOLD-YELLOW-RED
     ITALIC-90-200
     BRR-100-53
are acceptable color font faces.  Hence,
     (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY)
will create a color font.  LITATOM FACE arguments fall into one of the following patterns:
     wse                        wse-backcolor-forecolor
     STANDARD       STANDARD-backcolor-forecolor
     ITALIC                  ITALIC-backcolor-forecolor
     BOLD                    BOLD-backcolor-forecolor
     BOLDITALIC     BOLDITALIC-backcolor-forecolor
where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number.
1

(FONTPROP FONT PROP)  	[Function]
1

Returns the value of the PROP property of font FONT.  Besides black and white font properties, the following font properties are recognized:
	FORECOLOR	The color of the characters of the font, represented as a color number.  This is the color in which the characters of the font will print.
	BACKCOLOR	The color of the background of the characters of the font, represented as a color number.  This is the color in which the the background of characters of the font will print.  A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR.
Color Font Profiles
1


Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance.   The user can specify that different colors of fonts be used for different kinds of elements when printing in color.  A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example.  A FONTPROFILE such as
     ((DEFAULTFONT 1 (GACHA 10)
                   (GACHA 8)
                   (TERMINAL 8)
                   (4DISPLAY (GACHA 10 MRR-WHITE-RED))
                   (8DISPLAY (GACHA 10 MRR-WHITE-RED)))
      (BOLDFONT 2 (HELVETICA 10 BRR)
                (HELVETICA 8 BRR)
                (MODERN 8 BRR)
                (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))
                (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)))
      (LITTLEFONT 3 (HELVETICA 8)
                  (HELVETICA 6 MIR)
                  (MODERN 8 MIR)
                  (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))
                  (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)))
      (BIGFONT 4 (HELVETICA 12 BRR)
               (HELVETICA 10 BRR)
               (MODERN 10 BRR)
               (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))
               (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)))
      (USERFONT BOLDFONT)
      (COMMENTFONT LITTLEFONT)
      (LAMBDAFONT BIGFONT)
      (SYSTEMFONT)
      (CLISPFONT BOLDFONT)
      ...)
would have comments print in green and clisp words print in blue while ordinairy atoms would print in red.
Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set.
The user should indicate what  font is to be used for each font class by calling the function FONTPROFILE:
(FONTPROFILE PROFILE)  	[Function]
1

Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts.  Each element of PROFILE is a list of the form:
(FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1)  ... (OTHERDEVICEn OTHERFONTn))
FONTCLASS is the font class name and FONT# is the font number for that class.  DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively.  The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color  font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED).  
1

FONTPROFILE  	[Variable]
1

This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE.  Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 
1

2

Using Color
1

The current color implementation allows display streams to operate on color bitmaps.  The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function.
(DSPCOLOR COLOR STREAM)	[Function]
sets the foreground color of a stream.  It returns the previous foreground color.  If COLOR is NIL, it returns the current foreground color without changing anything.  The default foreground color is MINIMUMCOLOR=0,  which is white in the default color maps.
(DSPBACKCOLOR COLOR STREAM) 	 [Function]
sets the background color of a stream.   It returns the previous background color.  If COLOR is NIL, it returns the current background color without changing anything.  The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps.
The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream.  Following are some notes about them.
2

BITBLTing in Color
1


If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level.  Thus painting color 3 onto color 10 results in color 11.
If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR.  BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy.
If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color.  Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT  NIL  NIL  NIL  COLORSTR  50  75  100  200 'TEXTURE  'REPLACE  'BLUE).
2

Drawing Curves and Lines in Color
1

For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color.  A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR).  Also, a brush can be a bitmap (which can be a color bitmap).
Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap.
(DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION 
                          STREAM COLOR)	[Function]
(DRAWTO X Y WIDTH OPERATION STREAM COLOR)	[Function]
(RELDRAWTO X Y WIDTH OPERATION 
                                 STREAM COLOR)	[Function]
(DRAWBETWEEN POS1 POS2  WIDTH OPERATION
                                         STREAM COLOR)	[Function]
If the COLOR argument is NIL, the DSPCOLOR of the stream is used.
2

Printing in Color
1

Printing only works in REPLACE mode.  The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with.  
Example of printing to an 8bpp color screen:
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
(DSPFONT (FONTCREATE 'GACHA
                                                          10
                                                           'MRR-YELLOW-GREEN
                                                           0
                                                            '8DISPLAY)
                        FOO)
(PRINT 'HELLO FOO)	; will print in green against a yellow background.
2

Operating the Cursor on the Color Screen
1

The cursor can be moved to the color screen.  The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN.
(CURSORPOSITION NEWPOSITION - -)  	[Function]
1

NEWPOSITION can be a position or a screenposition.
(CURSORSCREEN SCREEN XCOORD YCOORD)  	[Function]
1

Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD.  SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN).
While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor.  It is automatically taken down whenever an operation is performed that changes any bits on the color screen.  The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen.  While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time.
  
2

Miscellaneous Color Functions
1

(COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL)	[Function]
creates a color bitmap from a black and white bitmap.  The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero.  This provides a way of producing a color bitmap from a black and white bitmap.
(UNCOLORIZEBITMAP BITMAP COLORMAP)	[Function]
creates a black and white bitmap from a color bitmap.
(SHOWCOLORTESTPATTERN BARSIZE)	[Function]
displays a pattern of colors on the color display.  This is useful when editing a color map.  The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen.  Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row.  The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers.  The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color���%�about 20). 
(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))));��� ���<��� ���T,���5����,���-KK�T3K���T,���9��� n�T3����T3����T3����T3����T3����T3�2�T3��T3��T3��T2����2����3��T3�2�T2����2����@�PAGEHEADING	VERSOHEAD@�PAGEHEADING	RECTOHEAD?�PAGEHEADINGFOOTINGV?�PAGEHEADINGFOOTINGR	?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8))
+MODERNMODERNMODERNMODERNMODERN
+MODERN
+MODERN
+MODERN
+HRULE.GETFNMODERN
+		HRULE.GETFNMODERN
+			HRULE.GETFNMODERN
+			HRULE.GETFNMODERN
+	
HRULE.GETFNMODERNHRULE.GETFNMODERN
HRULE.GETFNMODERN	�	�	�	K	f	�	�	HRULE.GETFNMODERN'HRULE.GETFNMODERN
+	@	�	�	HRULE.GETFNMODERN.HRULE.GETFNMODERN�		@	

+			W	�	(			"	�	=	HRULE.GETFNMODERN	HRULE.GETFNMODERN�	
+�	�	�		`		HRULE.GETFNMODERN	�	
+	]	
+	>	�		&										HRULE.GETFNMODERN	�	
+	�	
			?			=					�				"					"	HRULE.GETFNMODERNHRULE.GETFNMODERNy		D	+	q		B	-		i	(		_	

		L			*		X	=	�				*	�	
		?			N				�	HRULE.GETFNMODERN_		
+8	-			
+		Z		
+&	8	,			S						=				m	
+	
+)	
+	
+	
	
+	
	
+	/		�	�	�	;	�	�	HRULE.GETFNMODERNHRULE.GETFNMODERN�	
				v	4	
					)	E	�		�	HRULE.GETFNMODERNHRULE.GETFN,HRULE.GETFNMODERN�	HRULE.GETFNMODERN	�		�	
	2		"		1	HRULE.GETFNMODERN
+	�	+	+	�	
HRULE.GETFNMODERN
+	�	'	)	�	)HRULE.GETFNMODERN�	
	HRULE.GETFNMODERN
+	�	?	"		4	HRULE.GETFNMODERN
+	-	HRULE.GETFNMODERN
+	�			�	?	"		a	HRULE.GETFNMODERN
+	C	HRULE.GETFNMODERN
+		(BMOBJ.GETFN3�	H	�	,BMOBJ.GETFN3�	1	@							HRULE.GETFNMODERN
+	'	HRULE.GETFNMODERN
+	�	HRULE.GETFNMODERN
+	HRULE.GETFNMODERNHRULE.GETFNMODERN�	aIRM.GET.CREF	`	).  As of the LUTE release of Xerox Lisp, it is possible for the user to create and use windows and menus on the color display.
(CREATEW REGION TITLE BORDERSIZE NOOPENFLG)  	[Function]
1

Creates a new window.  REGION indicates where and how large the window should be by specifying the exterior screenregion of the window.  In a user environment with multiple screens, such as a black and white screen and color screen both connected to the same machine, there is a new special problem in indicating which screen the REGION is supposed to be a region of.  This problem is solved by allowing CREATEW to take screenregion arguments as REGION.  For example,
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
creates a window titled "FOO WINDOW" on the color screen.  To create a window on the black and white screen, the user should use SCREEN _ (MAINSCREEN) in the CREATE SCREENREGION expression.  Note that it is still perfectly legal to pass in a REGION  that is a region, not a screenregion, to CREATEW, but it is preferable to be passing screenregions rather than regions to CREATEW.  This is because when REGION is a region, REGION is disambiguated in a somewhat arbitrary manner that may not always turn out to be what the user was hoping for. 
When REGION is a region, REGION is disambiguated by coercing REGION to be a screenregion on the screen which currently contains the cursor.  This is so that software calling CREATEW with regions instead of screenregions tends to do the right thing in a user environment with multiple screens.
1

(WINDOWPROP WINDOW PROP NEWVALUE)  	[NoSpread Function]
1

If PROP='SCREEN, then WINDOWPROP returns the screen WINDOW is on.  If NEWVALUE is given, (even if given as NIL), with PROP='SCREEN, then WINDOWPROP will generate an error.  Any other PROP name is handled in the usual way.
1

(OPENWINDOWS SCREEN)  	[Function]
1

Returns a list of all open windows on SCREEN if SCREEN is a screen datatype such as (MAINSCREEN) or (COLORSCREEN).  If SCREEN=NIL, then SCREEN will default to the screen containing the cursor.  If SCREEN=T, then a list of all open windows on all screens is returned.
1

  
2

Color Fonts
1

The user can create color fonts and specify in the font profile that certain color fonts be used when printing in color.
Color Font Creation
1

The user can create and manipulate color fonts through the same functions that are used to create and manipulate black and white fonts.  This is made possible in some cases by there being new ways to call familiar  font  functions.
(FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)  	[Function]
1

In addition to creating black and white fonts, FONTCREATE can be used to create color fonts.  For example,
     (FONTCREATE 'GACHA 10
                                       '(BOLD REGULAR REGULAR YELLOW BLUE)
                                       0 '8DISPLAY)
will create an 8 bit per pixel font with blue letters on a yellow background.  The user indicates the color and bits per pixel of the font by the FACE and DEVICE arguments passed to FONTCREATE.  DEVICE='8DISPLAY means to create an 8bpp font and DEVICE='4DISPLAY means to create a 4bpp font.  A color font face is a 5 tuple,
     (WEIGHT SLOPE EXPANSION BACKCOLOR FORECOLOR)
whereas a black and white font face is just a 3 tuple,
     (WEIGHT SLOPE EXPANSION)
The FORECOLOR is the color of the characters of the font and the BACKCOLOR is the color of the background behind the characters that gets printed along with the characters.  Both BACKCOLOR and FORECOLOR are allowed to a color name, color number, or any other legal color representation.  A color font face can also be represented as a LITATOM.  A three character atom such as MRR or any of the special atoms STANDARD, ITALIC, BOLD, BOLDITALIC can optionally be continued by hyphenating on BACKCOLOR and FORECOLOR suffixes.  For example,
     MRR-YELLOW-BLUE
     BOLD-YELLOW-RED
     ITALIC-90-200
     BRR-100-53
are acceptable color font faces.  Hence,
     (FONTCREATE 'GACHA 10 'BOLD-YELLOW-BLUE 0 '8DISPLAY)
will create a color font.  LITATOM FACE arguments fall into one of the following patterns:
     wse                        wse-backcolor-forecolor
     STANDARD       STANDARD-backcolor-forecolor
     ITALIC                  ITALIC-backcolor-forecolor
     BOLD                    BOLD-backcolor-forecolor
     BOLDITALIC     BOLDITALIC-backcolor-forecolor
where w=B, M, or L; s=I or R; e=R, C, or E; backcolor=a color name or color number; and forecolor=a color name or color number.
1

(FONTPROP FONT PROP)  	[Function]
1

Returns the value of the PROP property of font FONT.  Besides black and white font properties, the following font properties are recognized:
	FORECOLOR	The color of the characters of the font, represented as a color number.  This is the color in which the characters of the font will print.
	BACKCOLOR	The color of the background of the characters of the font, represented as a color number.  This is the color in which the the background of characters of the font will print.  A font with red characters on a yellow background would have a red FORECOLOR and a yellow BACKCOLOR.
Color Font Profiles
1


Font profiles are the facility PRETTYPRINT uses to print different elements (user functions, system functions, clisp words, comments, etc.) in different fonts to emphasize (or deemphasize) their importance, and in general to provide for a more pleasing appearance.   The user can specify that different colors of fonts be used for different kinds of elements when printing in color.  A well chosen font profile will allows user to DEDIT functions, PP functions, and SEE source files in color, for example.  A FONTPROFILE such as
     ((DEFAULTFONT 1 (GACHA 10)
                   (GACHA 8)
                   (TERMINAL 8)
                   (4DISPLAY (GACHA 10 MRR-WHITE-RED))
                   (8DISPLAY (GACHA 10 MRR-WHITE-RED)))
      (BOLDFONT 2 (HELVETICA 10 BRR)
                (HELVETICA 8 BRR)
                (MODERN 8 BRR)
                (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))
                (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)))
      (LITTLEFONT 3 (HELVETICA 8)
                  (HELVETICA 6 MIR)
                  (MODERN 8 MIR)
                  (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))
                  (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)))
      (BIGFONT 4 (HELVETICA 12 BRR)
               (HELVETICA 10 BRR)
               (MODERN 10 BRR)
               (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))
               (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)))
      (USERFONT BOLDFONT)
      (COMMENTFONT LITTLEFONT)
      (LAMBDAFONT BIGFONT)
      (SYSTEMFONT)
      (CLISPFONT BOLDFONT)
      ...)
would have comments print in green and clisp words print in blue while ordinairy atoms would print in red.
Not all combinations of fonts will be aesthetically pleasing and the user may have to experiment to find a compatible set.
The user should indicate what  font is to be used for each font class by calling the function FONTPROFILE:
(FONTPROFILE PROFILE)  	[Function]
1

Sets up the font classes as determined by PROFILE, a list of elements which defines the correspondence between font classes and specific fonts.  Each element of PROFILE is a list of the form:
(FONTCLASS FONT# DISPLAYFONT PRESSFONT INTERPRESSFONT (OTHERDEVICE1 OTHERFONT1)  ... (OTHERDEVICEn OTHERFONTn))
FONTCLASS is the font class name and FONT# is the font number for that class.  DISPLAYFONT, PRESSFONT, and INTERPRESSFONT are font specifications (of the form accepted by FONTCREATE) for the fonts to use when printing to the black and white display and to Press and Interpress printers respectively.  The appearance of color fonts can be affected by including an (OTHERDEVICEi OTHERFONTi) entry where OTHERDEVICEi is either 4DISPLAY or 8DISPLAY for a 4 bits per pixel or 8 bits per pixel color  font and OTHERFONTi is a color font specification such as (GACHA 10 MRR-WHITE-RED).  
1

FONTPROFILE  	[Variable]
1

This is the variable used to store the current font profile, in the form accepted by the function FONTPROFILE.  Note that simply editing this value will not change the fonts used for the various font classes; it is necessary to execute (FONTPROFILE FONTPROFILE) to install the value of this variable. 
1

2

Using Color
1

The current color implementation allows display streams to operate on color bitmaps.  The two functions DSPCOLOR and DSPBACKCOLOR set the color in which a stream draws when the user defaults a color argument to a drawing function.
(DSPCOLOR COLOR STREAM)	[Function]
sets the foreground color of a stream.  It returns the previous foreground color.  If COLOR is NIL, it returns the current foreground color without changing anything.  The default foreground color is MINIMUMCOLOR=0,  which is white in the default color maps.
(DSPBACKCOLOR COLOR STREAM) 	 [Function]
sets the background color of a stream.   It returns the previous background color.  If COLOR is NIL, it returns the current background color without changing anything.  The default background color is (MAXIMUMCOLOR BITSPERPIXEL)=15 or 255, which is black in the default color maps.
The BITBLT, line-drawing routines, and curve-drawing routines routines know how to operate on a color-capable stream.  Following are some notes about them.
2

BITBLTing in Color
1


If BITBLTing from a color bitmap onto another color bitmap of the same bpp, the operations PAINT, INVERT, and ERASE are done on a bit level, not on a pixel level.  Thus painting color 3 onto color 10 results in color 11.
If BITBLTing from a black-and-white bitmap onto a color bitmap, the one bits appear in the DSPCOLOR, and the zero bits in DSPBACKCOLOR.  BLTing from black-and-white to color is fairly expensive; if the same bitmap is going to be put up several times in the same color, it is faster to create a color copy and then BLT the color copy.
If the source type is TEXTURE and the destination bitmap is a color bitmap, the Texture argument is taken to be a color.  Thus to fill an area with the color BLUE assuming COLORSTR is a stream whose destination is the color screen, use (BITBLT  NIL  NIL  NIL  COLORSTR  50  75  100  200 'TEXTURE  'REPLACE  'BLUE).
2

Drawing Curves and Lines in Color
1

For the functions DRAWCIRCLE, DRAWELLIPSE, and DRAWCURVE, the notion of a brush has been extended to include a color.  A BRUSH is now (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR).  Also, a brush can be a bitmap (which can be a color bitmap).
Line-drawing routines take a color argument which is the color the line is to appear in if the destination of the display stream is a color bitmap.
(DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION 
                          STREAM COLOR)	[Function]
(DRAWTO X Y WIDTH OPERATION STREAM COLOR)	[Function]
(RELDRAWTO X Y WIDTH OPERATION 
                                 STREAM COLOR)	[Function]
(DRAWBETWEEN POS1 POS2  WIDTH OPERATION
                                         STREAM COLOR)	[Function]
If the COLOR argument is NIL, the DSPCOLOR of the stream is used.
2

Printing in Color
1

Printing only works in REPLACE mode.  The characters have a background color and a foreground color determined by the font face of the font the characters are being printed with.  
Example of printing to an 8bpp color screen:
(SETQ FOO (CREATEW (CREATE SCREENREGION
                                                                         SCREEN _ (COLORSCREEN)
                                                                         LEFT _ 20
                                                                         BOTTOM _ 210
                                                                         WIDTH _ 290
                                                                         HEIGHT _ 170)
                                                      "FOO WINDOW"))
(DSPFONT (FONTCREATE 'GACHA
                                                          10
                                                           'MRR-YELLOW-GREEN
                                                           0
                                                            '8DISPLAY)
                        FOO)
(PRINT 'HELLO FOO)	; will print in green against a yellow background.
2

Operating the Cursor on the Color Screen
1

The cursor can be moved to the color screen.  The cursor can be moved to the color screen by sliding the cursor off the left or right edge of the black and white screen on to the color screen or by calling function CURSORPOSITION or CURSORSCREEN.
(CURSORPOSITION NEWPOSITION - -)  	[Function]
1

NEWPOSITION can be a position or a screenposition.
(CURSORSCREEN SCREEN XCOORD YCOORD)  	[Function]
1

Moves the cursor to the screenposition determined by SCREEN, XCOORD, and YCOORD.  SCREEN should be the value of either (COLORSCREEN) or (MAINSCREEN).
While on the color screen, the cursor is placed by doing BITBLTs in software rather than with microcode and hardware as with the black and white cursor.  It is automatically taken down whenever an operation is performed that changes any bits on the color screen.  The speed of the color cursor compares well with that of the black and white cursor but there can be a noticeable flicker when there is much input/output to the color screen.  While the cursor is on the color screen, the black-and-white cursor is cleared giving the appearance that there is never more than one cursor at a given time.
  
2

Miscellaneous Color Functions
1

(COLORIZEBITMAP BITMAP 0COLOR 1COLOR BITSPERPIXEL)	[Function]
creates a color bitmap from a black and white bitmap.  The returned bitmap has color number 1COLOR in those pixels of BITMAP that were one and 0COLOR in those pixels of BITMAP that were zero.  This provides a way of producing a color bitmap from a black and white bitmap.
(UNCOLORIZEBITMAP BITMAP COLORMAP)	[Function]
creates a black and white bitmap from a color bitmap.
(SHOWCOLORTESTPATTERN BARSIZE)	[Function]
displays a pattern of colors on the color display.  This is useful when editing a color map.  The pattern has squares of the 16 possible colors laid out in two rows at the top of the screen.  Colors 0 through 7 are in the top row, and colors 8 through 15 are in the next row.  The bottom part of the screen is filled with bars of BARSIZE width with consecutive color numbers.  The pattern is designed so that every color has a border with every other color (unless BARSIZE is too large to allow room for every color���%�about 20). 
(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC) STARTINGPAGE# 2) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 618) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (558 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC)) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM) FORMATINFO (ARABIC)) (54 12 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL)))));��� ���<��� ���T,���5����,���-KK�T3K���T,���9��� n�T3����T3����T3����T3����T3����T3�2�T3��T3��T3��T2����2����3��T3�2�T2����2����@�PAGEHEADING	VERSOHEAD@�PAGEHEADING	RECTOHEAD?�PAGEHEADINGFOOTINGV?�PAGEHEADINGFOOTINGROPTIMAOPTIMAOPTIMA
+OPTIMA
+OPTIMA
+OPTIMAOPTIMAOPTIMA
+HRULE.GETFNOPTIMA
+-HRULE.GETFNOPTIMA
+-HRULE.GETFNOPTIMA
+HRULE.GETFNOPTIMA
+
HRULE.GETFNOPTIMAHRULE.GETFNOPTIMA
HRULE.GETFNOPTIMA���Kf��HRULE.GETFNOPTIMA'HRULE.GETFNOPTIMA
+@��HRULE.GETFNOPTIMA.HRULE.GETFNOPTIMA�@

+W�("�=HRULE.GETFNOPTIMA	HRULE.GETFNOPTIMA�
+���`HRULE.GETFNOPTIMA�
+]
+>�	&HRULE.GETFNOPTIMA�
+�
?=�""HRULE.GETFNOPTIMAHRULE.GETFNOPTIMAyD+qB-k(a

N*X=�	*�
?	N	�HRULE.GETFNOPTIMA_
+8-
+	Z
+&8,S=m
+
+)
+
+

+

+/���;��HRULE.GETFNOPTIMAHRULE.GETFNOPTIMA�
v4
)E��HRULE.GETFNOPTIMAHRULE.GETFN,HRULE.GETFNOPTIMA�HRULE.GETFNOPTIMA��
2"1HRULE.GETFNOPTIMA
+�++�
HRULE.GETFNOPTIMA
+�')�)HRULE.GETFNOPTIMA�
HRULE.GETFNOPTIMA
+�?"4HRULE.GETFNOPTIMA
+-HRULE.GETFNOPTIMA
+�	�?"aHRULE.GETFNOPTIMA
+CHRULE.GETFNOPTIMA
+(BMOBJ.GETFN3�H�,BMOBJ.GETFN3�1@		HRULE.GETFNOPTIMA
+'HRULE.GETFNOPTIMA
+�HRULE.GETFNOPTIMA
+HRULE.GETFNOPTIMAHRULE.GETFNOPTIMA�#4IRM.GET.CREF�?IRM.GET.CREF�	!HRULE.GETFNOPTIMA
+-n(`SVUWE��s�HRULE.GETFNOPTIMA
+HRULE.GETFNOPTIMA
+-(="HRULE.GETFNOPTIMA
+
HRULE.GETFNOPTIMA
+&A7@HRULE.GETFNOPTIMA
+HRULE.GETFNOPTIMAHRULE.GETFNOPTIMAyHRULE.GETFNOPTIMA�3HRULE.GETFNOPTIMA
+kK4D27):[81863�HRULE.GETFNOPTIMA
+
+	HRULE.GETFNOPTIMA
+Z	�	HRULE.GETFNOPTIMA�	  78%"<="$!;<$"89k{k
HRULE.GETFNOPTIMA
+*p			%	�
[
+CHRULE.GETFNOPTIMA
+HRULE.GETFNOPTIMA
+E�HRULE.GETFNOPTIMA
+HRULE.GETFNOPTIMAHRULE.GETFNOPTIMA�	V�
W��HRULE.GETFNOPTIMAHRULE.GETFNOPTIMA�NP�HRULE.GETFNOPTIMA"HRULE.GETFNOPTIMA��	
+& 
+
+-
+55HRULE.GETFNOPTIMAHRULE.GETFNOPTIMA�-(`SVUWE=M=GFHRULE.GETFNOPTIMA)HRULE.GETFNOPTIMA�HRULE.GETFNOPTIMA
+(HRULE.GETFNOPTIMA
+5>WHRULE.GETFNOPTIMAHRULE.GETFNOPTIMA!\a6J�+}��z�
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/COLORDEMO b/internal/library/OBSOLETE/COLORDEMO
new file mode 100644
index 00000000..fc45673f
--- /dev/null
+++ b/internal/library/OBSOLETE/COLORDEMO
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 12:28:24" {DSK}<usr>local>lde>lispcore>internal>library>COLORDEMO.;2 58060  

      changes to%:  (VARS COLORDEMOCOMS)

      previous date%: " 3-Sep-86 21:36:32" {DSK}<usr>local>lde>lispcore>internal>library>COLORDEMO.;1
)


(* ; "
Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT COLORDEMOCOMS)

(RPAQQ COLORDEMOCOMS
       [(* * COLORDEMO -- Color demonstration programs. By Richard Burton and Kelly Roach. *)
        (COMS (* Color Demo. Stuff needed to run through different demos, but not the individual 
                 demos themselves. *)
              [VARS (CD.DEMOS '(KINETICDEMO VINEDEMO RAINING MODARTDEMO STARBURSTDEMO COLORPEANODEMO
                                      BUBBLEDEMO OVERPAINTDEMO TILEDEMO TUNNELDEMO POLYGONSDEMO]
              (INITVARS (CD.NEWDEMO NIL)
                     (CD.STOPDATE 0)
                     (CD.TIMECELL NIL)
                     (CD.WINDOW1 NIL)
                     (CD.WINDOW2 NIL)
                     (CD.WINDOW3 NIL)
                     (CD.WINDOW4 NIL)
                     (CD.MENU NIL)
                     (CD.COLORMAPS NIL))
              (GLOBALVARS CD.DEMOS CD.NEWDEMO CD.STOPDATE)
              (FNS COLORDEMO CD.INIT CD.INIT.COLORMAPS CD.INIT.WINDOWS CD.INIT.MENU CD.NEXTELEMENT 
                   CD.RANDELEMENT CD.CHOOSEDEMO CD.QUITP))
        (COMS (* Tunnel demo. *)
              (FNS CD.MINESHAFT CD.POINTTEST)
              (FNS WELLDEMO TUNNELDEMO CD.SQUARETUNNEL CD.CIRCULARTUNNEL))
        (COMS (* Junk fns. *)
              (FNS CD.ROTATEIT)
              (FNS COLORMAPOF COLORMAPCOPY COLORFILL COLORBACKGROUND COLORFILLAREA))
        (COMS (* Walk demos)
              (FNS WALKDEMO CD.WALKBM CD.RANDCOLORMAP)
              [INITVARS CD.MAXWALK CD.MINWALK CD.RANDCOLORPROB (CD.RANDOM.COLORMAP NIL)
                     (CD.RAINBOW.COLORMAP NIL)
                     (CD.8BITBMEXP (LIST (HARRAY 60)))
                     (CD.4BITBMEXP (LIST (HARRAY 60]
              (GLOBALVARS CD.8BITBMEXP CD.4BITBMEXP CD.RANDOM.COLORMAP CD.RAINBOW.COLORMAP))
        (COMS (* Kinetic demos *)
              (FNS KINETICDEMO CD.DEMOKINETIC CD.CIRKIN)
              (VARS (CD.KINETICWAITTIME 150))
              (GLOBALVARS CD.KINETICWAITTIME))
        (COMS (* Vine demo *)
              (FNS VINEDEMO CD.INRANGE))
        (COMS (* Raining demo *)
              (FNS RAINING CD.PUTDROPS CD.DOCOLORDROP CD.RAININGCOLORMAP))
        (COMS (* Modart demo *)
              (FNS MODARTDEMO))
        (COMS (* Starburst demo *)
              (FNS STARBURSTDEMO CD.STARBURST CD.STARSHINE))
        (COMS (* Peano demo *)
              (FILES (FROM LISPUSERS)
                     PEANO)
              (FNS COLORPEANODEMO))
        (COMS (* Bubble demo *)
              (FNS BUBBLEDEMO CD.BUBBLE))
        (COMS (* Overpaint demo *)
              (FNS OVERPAINTDEMO)
              (VARS (CD.OVERPAINTBITMAPS)))
        (COMS (* Tile demo *)
              (INITVARS (CD.TILEBITMAPS NIL))
              (FNS TILEDEMO))
        (COMS (* Polygons demo *)
              (FILES (FROM LISPUSERS)
                     COLORPOLYGONS)
              (FNS POLYGONSDEMO))
        (FILES COLOR)
        (COMS (* Color font profile *)
              (VARS COLORFONTPROFILE)
              (P (FONTPROFILE COLORFONTPROFILE)
                 (* Create color fonts now instead of later. COLOR should already be LOADed. *)
                 (for FONTCLASS in (LIST DEFAULTFONT BOLDFONT LITTLEFONT BIGFONT)
                      do
                      (FONTCREATE FONTCLASS NIL NIL NIL '8DISPLAY))
                 (FONTCREATE 'TIMESROMAND 36 NIL NIL NIL '8DISPLAY])
(* * COLORDEMO -- Color demonstration programs. By Richard Burton and Kelly Roach. *)




(* Color Demo. Stuff needed to run through different demos, but not the individual demos themselves.
 *)


(RPAQQ CD.DEMOS (KINETICDEMO VINEDEMO RAINING MODARTDEMO STARBURSTDEMO COLORPEANODEMO BUBBLEDEMO
                           OVERPAINTDEMO TILEDEMO TUNNELDEMO POLYGONSDEMO))

(RPAQ? CD.NEWDEMO NIL)

(RPAQ? CD.STOPDATE 0)

(RPAQ? CD.TIMECELL NIL)

(RPAQ? CD.WINDOW1 NIL)

(RPAQ? CD.WINDOW2 NIL)

(RPAQ? CD.WINDOW3 NIL)

(RPAQ? CD.WINDOW4 NIL)

(RPAQ? CD.MENU NIL)

(RPAQ? CD.COLORMAPS NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS CD.DEMOS CD.NEWDEMO CD.STOPDATE)
)
(DEFINEQ

(COLORDEMO
  [LAMBDA NIL                                            (* kbr%: " 3-Sep-86 21:19")
    (DECLARE (GLOBALVARS CD.DEMOS CD.NEWDEMO CD.STOPDATE CD.COLORMAPS))
    (PROG (WINDOWS WINDOW DEMO BITSPERPIXEL BITMAP)
          (COND
             ((NULL CD.MENU)
              (CD.INIT)))
          [COND
             [(NULL (WFROMMENU CD.MENU))
              (ADDMENU CD.MENU NIL (GETBOXPOSITION (fetch (MENU IMAGEWIDTH) of CD.MENU)
                                          (fetch (MENU IMAGEHEIGHT) of CD.MENU]
             ((NOT (OPENWP (WFROMMENU CD.MENU)))
              (OPENW (WFROMMENU CD.MENU]
          (SETQ WINDOWS (LIST CD.WINDOW1 CD.WINDOW2 CD.WINDOW3 CD.WINDOW4))
          [do (SETQ WINDOW (CD.NEXTELEMENT WINDOW WINDOWS))
                 (SETQ DEMO (OR CD.NEWDEMO (CD.NEXTELEMENT DEMO CD.DEMOS)))
                 (SETQ CD.NEWDEMO NIL)
                 (COND
                    ((EQ DEMO 'STOP)
                     (RETURN)))
                 (SETQ CD.STOPDATE (IPLUS (IDATE)
                                          60)) 

         (* Each DEMO takes a WAIT argument telling how long to run and an optional 
       WINDOW argument telling which window to use.
       WAIT can be defaulted to NIL. *)

                 (SCREENCOLORMAP (CD.RANDELEMENT CD.COLORMAPS))
                 (APPLY* DEMO NIL WINDOW)
                 (COND
                    ((ILESSP (LENGTH CD.TILEBITMAPS)
                            10)
                     (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP)))
                     (SETQ BITMAP (BITMAPCREATE 100 100 BITSPERPIXEL))
                     (BITBLT WINDOW NIL NIL BITMAP)
                     (push CD.TILEBITMAPS BITMAP]
          (CLOSEW (WFROMMENU CD.MENU])

(CD.INIT
  [LAMBDA NIL                                            (* kbr%: " 3-Sep-86 19:06")
    (PROG NIL
          (CD.INIT.COLORMAPS)
          (CD.INIT.WINDOWS)
          (CD.INIT.MENU])

(CD.INIT.COLORMAPS
  [LAMBDA NIL                                            (* kbr%: " 3-Sep-86 20:39")
    (PROG (BITSPERPIXEL MAXCOLOR)
          (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP)))
          (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL))
          (SETQ CD.CMYCOLORMAP (SELECTQ BITSPERPIXEL
                                   (4 (CMYCOLORMAP 2 1 1 4))
                                   (8 (CMYCOLORMAP 3 2 2 8))
                                   NIL))
          (SETQ CD.RGBCOLORMAP (SELECTQ BITSPERPIXEL
                                   (4 (CMYCOLORMAP 2 1 1 4))
                                   (8 (RGBCOLORMAP 3 2 2 8))
                                   NIL))
          (SETQ CD.RANDOM.COLORMAP (COLORMAPCREATE (for COLOR from 0 to MAXCOLOR
                                                      collect (create RGB
                                                                         RED _ (RAND 0 255)
                                                                         GREEN _ (RAND 0 255)
                                                                         BLUE _ (RAND 0 255)))
                                          BITSPERPIXEL))
          [PROGN (SETQ CD.RAINBOW.COLORMAP (RAINBOWMAP BITSPERPIXEL))
                 (for COLOR from (RAND 0 15) to MAXCOLOR by 16
                    do (SETA CD.RAINBOW.COLORMAP COLOR (create RGB
                                                                  RED _ (RAND 0 255)
                                                                  GREEN _ (RAND 0 255)
                                                                  BLUE _ (RAND 0 255]
          (SETQ CD.COLORMAPS (LIST CD.CMYCOLORMAP CD.RGBCOLORMAP CD.RANDOM.COLORMAP 
                                   CD.RAINBOW.COLORMAP))
          (RETURN CD.COLORMAPS])

(CD.INIT.WINDOWS
  [LAMBDA NIL                                            (* kbr%: " 3-Sep-86 18:34")
    (PROG (CSWIDTH CSHEIGHT TAB NORTHWEST NORTHEAST SOUTHWEST SOUTHEAST NORTH EAST SOUTH WEST WIDTH 
                 HEIGHT)
          (SETQ CSWIDTH (BITMAPWIDTH (COLORSCREENBITMAP)))
          (SETQ CSHEIGHT (BITMAPHEIGHT (COLORSCREENBITMAP)))
          (SETQ TAB 20)
          (SETQ WIDTH (IQUOTIENT (IDIFFERENCE CSWIDTH (ITIMES 3 TAB))
                             2))
          (SETQ HEIGHT (IQUOTIENT (IDIFFERENCE CSHEIGHT (ITIMES 3 TAB))
                              2))
          (SETQ NORTHWEST (create POSITION
                                 XCOORD _ TAB
                                 YCOORD _ (IPLUS TAB HEIGHT TAB)))
          (SETQ NORTHEAST (create POSITION
                                 XCOORD _ (IPLUS TAB WIDTH TAB)
                                 YCOORD _ (IPLUS TAB HEIGHT TAB)))
          (SETQ SOUTHWEST (create POSITION
                                 XCOORD _ TAB
                                 YCOORD _ TAB))
          (SETQ SOUTHEAST (create POSITION
                                 XCOORD _ (IPLUS TAB WIDTH TAB)
                                 YCOORD _ TAB))
          [SETQ NORTH (create POSITION
                             XCOORD _ (IQUOTIENT (IDIFFERENCE CSWIDTH WIDTH)
                                             2)
                             YCOORD _ (IDIFFERENCE CSHEIGHT (IPLUS TAB HEIGHT]
          (SETQ EAST (create POSITION
                            XCOORD _ (IDIFFERENCE CSWIDTH (IPLUS WIDTH TAB))
                            YCOORD _ (IQUOTIENT (IDIFFERENCE CSHEIGHT HEIGHT)
                                            2)))
          (SETQ SOUTH (create POSITION
                             XCOORD _ (IQUOTIENT (IDIFFERENCE CSWIDTH WIDTH)
                                             2)
                             YCOORD _ TAB))
          (SETQ WEST (create POSITION
                            XCOORD _ TAB
                            YCOORD _ (IQUOTIENT (IDIFFERENCE CSHEIGHT HEIGHT)
                                            2)))
          (SETQ CD.WINDOW1 (CREATEW (create SCREENREGION
                                           SCREEN _ (COLORSCREEN)
                                           LEFT _ (fetch (POSITION XCOORD) of NORTHWEST)
                                           BOTTOM _ (fetch (POSITION YCOORD) of NORTHWEST)
                                           WIDTH _ WIDTH
                                           HEIGHT _ HEIGHT)
                                  'WINDOW1))
          (SETQ CD.WINDOW2 (CREATEW (create SCREENREGION
                                           SCREEN _ (COLORSCREEN)
                                           LEFT _ (fetch (POSITION XCOORD) of NORTHEAST)
                                           BOTTOM _ (fetch (POSITION YCOORD) of NORTHEAST)
                                           WIDTH _ WIDTH
                                           HEIGHT _ HEIGHT)
                                  'WINDOW2))
          (SETQ CD.WINDOW3 (CREATEW (create SCREENREGION
                                           SCREEN _ (COLORSCREEN)
                                           LEFT _ (fetch (POSITION XCOORD) of SOUTHWEST)
                                           BOTTOM _ (fetch (POSITION YCOORD) of SOUTHWEST)
                                           WIDTH _ WIDTH
                                           HEIGHT _ HEIGHT)
                                  'WINDOW3))
          (SETQ CD.WINDOW4 (CREATEW (create SCREENREGION
                                           SCREEN _ (COLORSCREEN)
                                           LEFT _ (fetch (POSITION XCOORD) of SOUTHEAST)
                                           BOTTOM _ (fetch (POSITION YCOORD) of SOUTHEAST)
                                           WIDTH _ WIDTH
                                           HEIGHT _ HEIGHT)
                                  'WINDOW4])

(CD.INIT.MENU
  [LAMBDA NIL                                            (* kbr%: "11-Aug-85 15:05")
    (SETQ CD.MENU (create MENU
                         TITLE _ "Color Demos"
                         ITEMS _ (APPEND CD.DEMOS '(STOP))
                         WHENSELECTEDFN _ 'CD.CHOOSEDEMO])

(CD.NEXTELEMENT
  [LAMBDA (ELEMENT LIST)                                 (* kbr%: "10-Jul-85 18:12")
                                                             (* Pick element after ELEMENT in 
                                                           rotating LIST. *)
    (PROG (TAIL ANSWER)
          (SETQ TAIL (FMEMB ELEMENT LIST))
          [SETQ ANSWER (COND
                          ((CDR TAIL)
                           (CADR TAIL))
                          (T (CAR LIST]
          (RETURN ANSWER])

(CD.RANDELEMENT
  [LAMBDA (LIST)                                         (* kbr%: "31-Jan-86 16:24")
    (CAR (NTH LIST (RAND 1 (LENGTH LIST])

(CD.CHOOSEDEMO
  [LAMBDA (NEW)
    (DECLARE (GLOBALVARS CD.NEWDEMO))                (* bas%: " 5-JUN-82 13:07")
    (SETQ CD.NEWDEMO NEW])

(CD.QUITP
  [LAMBDA (N)                                            (* kbr%: " 3-Sep-86 20:05")
    (DECLARE (GLOBALVARS CD.NEWDEMO CD.STOPDATE))
    (BLOCK)
    (OR CD.TIMECELL (SETQ CD.TIMECELL (CREATECELL \FIXP)))
    (OR CD.NEWDEMO (COND
                      ((FIXP N)
                       (SETQ CD.STOPDATE (IPLUS (ITIMES N 1000)
                                                (CLOCK 0 CD.TIMECELL)))
                       NIL)
                      (T (AND CD.STOPDATE (ILESSP CD.STOPDATE (CLOCK 0 CD.TIMECELL])
)



(* Tunnel demo. *)

(DEFINEQ

(CD.MINESHAFT
  [LAMBDA (WINDOW N OUTFLG)                              (* kbr%: "20-Jun-91 11:02")
                                                             (* Draws a mineshaft on WINDOW.)
    (PROG (COLOR WIDTH HEIGHT MAXCOLOR)
          (WINDOWPROP WINDOW 'TITLE 'CD.MINESHAFT)
          (COND
             ((NULL N)
              (SETQ N 1)))
          (SETQ COLOR 0)
          (SETQ WIDTH (WINDOWPROP WINDOW 'WIDTH))
          (SETQ HEIGHT (WINDOWPROP WINDOW 'HEIGHT))
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
          (for LEFT from 0 by (ITIMES N 4) as BOTTOM from 0
             by (ITIMES N 3) to (IQUOTIENT HEIGHT 2)
             do (BLTSHADE COLOR WINDOW LEFT BOTTOM (IDIFFERENCE WIDTH (ITIMES LEFT 2))
                           (IDIFFERENCE HEIGHT (ITIMES BOTTOM 2)))
                   (COND
                      [OUTFLG (SETQ COLOR (SUB1 COLOR))
                             (COND
                                ((ILESSP COLOR 0)
                                 (SETQ COLOR MAXCOLOR]
                      (T (SETQ COLOR (ADD1 COLOR))
                         (COND
                            ((IGREATERP COLOR MAXCOLOR)
                             (SETQ COLOR 0])

(CD.POINTTEST
  [LAMBDA (WINDOW)                                       (* kbr%: " 8-Jul-85 09:44")
                                                             (* randomly puts points in a region)
    (PROG (MAXX MAXY MAXCOLOR)
          [SETQ MAXX (SUB1 (WINDOWPROP WINDOW 'WIDTH]
          [SETQ MAXY (SUB1 (WINDOWPROP WINDOW 'HEIGHT]
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
          (for I from 1 to 100 do (BITMAPBIT WINDOW (RAND 0 MAXX)
                                                         (RAND 0 MAXY)
                                                         (RAND 0 MAXCOLOR])
)
(DEFINEQ

(WELLDEMO
  [LAMBDA (WAIT)                                         (* kbr%: " 3-Sep-86 20:08")
    (PROG (STARTCOLOR THRUCOLOR)
          (SETQ STARTCOLOR 1)
          (SETQ THRUCOLOR 14)
          (CD.SQUARETUNNEL CD.WINDOW1 4 STARTCOLOR THRUCOLOR)
          (CD.SQUARETUNNEL CD.WINDOW2 4 THRUCOLOR STARTCOLOR)
          (CD.CIRCULARTUNNEL CD.WINDOW3 4 THRUCOLOR STARTCOLOR)
          (CD.CIRCULARTUNNEL CD.WINDOW4 4 STARTCOLOR THRUCOLOR)
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP) do (ROTATECOLORMAP STARTCOLOR THRUCOLOR])

(TUNNELDEMO
  [LAMBDA (WAIT)                                         (* kbr%: " 3-Sep-86 20:08")
    (PROG (STARTCOLOR THRUCOLOR)
          (SETQ STARTCOLOR 1)
          (SETQ THRUCOLOR 14)
          (CD.SQUARETUNNEL CD.WINDOW1 STARTCOLOR THRUCOLOR)
          (CD.SQUARETUNNEL CD.WINDOW2 THRUCOLOR STARTCOLOR)
          (CD.CIRCULARTUNNEL CD.WINDOW3 THRUCOLOR STARTCOLOR)
          (CD.CIRCULARTUNNEL CD.WINDOW4 STARTCOLOR THRUCOLOR)
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP) do (ROTATECOLORMAP STARTCOLOR THRUCOLOR])

(CD.SQUARETUNNEL
  [LAMBDA (WINDOW STARTCOLOR THRUCOLOR)                  (* kbr%: "24-Feb-86 12:16")
                                                             (* Draws a CD.SQUARETUNNEL on the 
                                                           WINDOW.)
    (PROG (LEFT BOTTOM MAXBOTTOM FACTOR LEFTFACTOR BOTTOMFACTOR INCR DELTA COLOR)
          (SETQ LEFT 0.0)
          (SETQ BOTTOM 0.0)
          (SETQ MAXBOTTOM (FQUOTIENT (BITMAPHEIGHT WINDOW)
                                 2.0))
          (SETQ FACTOR 0.2)
          (SETQ LEFTFACTOR (FTIMES 4.0 FACTOR))
          (SETQ BOTTOMFACTOR (FTIMES 3.0 FACTOR))
          (COND
             ((IGEQ THRUCOLOR STARTCOLOR)
              (SETQ DELTA 1))
             (T (SETQ DELTA -1)))
          (SETQ COLOR STARTCOLOR)
          (do (BLTSHADE COLOR WINDOW (FIX LEFT)
                         (FIX BOTTOM)
                         (IDIFFERENCE (BITMAPWIDTH WINDOW)
                                (FTIMES LEFT 2))
                         (IDIFFERENCE (BITMAPHEIGHT WINDOW)
                                (FTIMES BOTTOM 2)))
                 [SETQ INCR (FPLUS 1.0 (FTIMES 0.1 (FDIFFERENCE MAXBOTTOM BOTTOM]
                 (SETQ LEFT (FPLUS LEFT (FTIMES INCR LEFTFACTOR)))
                 (SETQ BOTTOM (FPLUS BOTTOM (FTIMES INCR BOTTOMFACTOR)))
                 (COND
                    ((FGREATERP BOTTOM MAXBOTTOM)
                     (RETURN)))
                 (COND
                    ((EQ COLOR THRUCOLOR)
                     (SETQ COLOR STARTCOLOR))
                    (T (SETQ COLOR (IPLUS COLOR DELTA])

(CD.CIRCULARTUNNEL
  [LAMBDA (WINDOW STARTCOLOR THRUCOLOR)                  (* kbr%: "24-Feb-86 12:23")
    (PROG (N WIDTH HEIGHT SIZE DELTA COLOR)
          (SETQ N 4)
          (SETQ WIDTH (BITMAPWIDTH WINDOW))
          (SETQ HEIGHT (BITMAPHEIGHT WINDOW))
          (SETQ SIZE (IQUOTIENT (SQRT (IPLUS (ITIMES WIDTH WIDTH)
                                             (ITIMES HEIGHT HEIGHT)))
                            2))
          (COND
             ((IGEQ THRUCOLOR STARTCOLOR)
              (SETQ DELTA 1))
             (T (SETQ DELTA -1)))
          (SETQ COLOR STARTCOLOR)
          (for I from 1 to SIZE by N do 

         (* Have to make the brush a little bit thicker than the amount by which we are 
       incrementing the radius to avoid cracks appearing between circles.
       *)

                                                           (DRAWCIRCLE (IQUOTIENT WIDTH 2)
                                                                  (IQUOTIENT HEIGHT 2)
                                                                  I
                                                                  (LIST 'ROUND (IPLUS N 2)
                                                                        COLOR)
                                                                  NIL WINDOW)
                                                           (COND
                                                              ((EQ COLOR THRUCOLOR)
                                                               (SETQ COLOR STARTCOLOR))
                                                              (T (SETQ COLOR (IPLUS COLOR DELTA])
)



(* Junk fns. *)

(DEFINEQ

(CD.ROTATEIT
  [LAMBDA (BEGINCOLOR ENDCOLOR WAIT)                     (* kbr%: "23-Feb-86 17:30")
    (PROG NIL
          (do (ROTATECOLORMAP BEGINCOLOR ENDCOLOR)
                 (COND
                    ((NULL WAIT))
                    ((SMALLP WAIT)
                     (DISMISS WAIT))
                    (T (GETMOUSESTATE)
                       (DISMISS (LRSH LASTMOUSEX 3])
)
(DEFINEQ

(COLORMAPOF
  [LAMBDA (NEWCM BITSPERPIXEL)                           (* kbr%: " 3-Sep-86 16:24")
    (COND
       [(COLORMAPP NEWCM)
        (COND
           ((EQ BITSPERPIXEL (COLORMAPBITS NEWCM))
            NEWCM)
           (T (COLORMAPCOPY NEWCM BITSPERPIXEL]
       ((EQ NEWCM T)
        (COLORMAPCREATE NIL BITSPERPIXEL))
       (T (COLORMAPCREATE NEWCM BITSPERPIXEL])

(COLORMAPCOPY
  [LAMBDA (COLORMAP BITSPERPIXEL)                        (* rrb "21-OCT-82 18:32")

         (* makes a copy of a color map If COLORMAP is not a color map, it returns a new 
       color map with default values. If the colormaps are different sizes, the first 
       16 entries will be the same and the rest will be black)

    (COLORMAPCREATE (AND (COLORMAPP COLORMAP BITSPERPIXEL)
                         (INTENSITIESFROMCOLORMAP COLORMAP))
           BITSPERPIXEL])

(COLORFILL
  [LAMBDA (REGION COLOR# COLORBM OPERATION)              (* rrb "21-DEC-82 20:54")

         (* fills a region in a color bitmap with a color.
       Calls the standard BITBLT with a texture.)

    (PROG (COLORBM)
          [SETQ COLORBM (COND
                           ((TYPENAMEP COLORBM 'BITMAP)
                            COLORBM)
                           ((NULL COLORBM)
                            (COLORSCREENBITMAP))
                           (T (\ILLEGAL.ARG COLORBM]
          (COND
             ((NULL REGION)
              (COLORFILLAREA 0 0 NIL NIL COLOR# COLORBM OPERATION))
             (T (COLORFILLAREA (fetch (REGION LEFT) of REGION)
                       (fetch (REGION BOTTOM) of REGION)
                       (fetch (REGION WIDTH) of REGION)
                       (fetch (REGION HEIGHT) of REGION)
                       COLOR# COLORBM OPERATION])

(COLORBACKGROUND
  [LAMBDA (TEXTURE)                                      (* kbr%: " 3-Sep-86 16:30")
    (CHANGEBACKGROUND TEXTURE (COLORSCREEN])

(COLORFILLAREA
  [LAMBDA (LEFT BOTTOM WIDTH HEIGHT COLOR# COLORBM OPERATION)
                                                             (* kbr%: " 8-Jul-85 08:53")
                                                             (* fills an area of a color bitmap 
                                                           with color.)
    [COND
       ((NULL COLORBM)
        (SETQ COLORBM (COLORSCREENBITMAP]
    (BITBLT NIL NIL NIL COLORBM LEFT BOTTOM WIDTH HEIGHT 'TEXTURE OPERATION COLOR#])
)



(* Walk demos)

(DEFINEQ

(WALKDEMO
  [LAMBDA (WINDOW WAIT SPEED WORD1 WORDS)                (* kbr%: " 3-Sep-86 18:50")
    (DECLARE (GLOBALVARS CD.STOPDATE))
    (PROG NIL
          (CLEARW WINDOW)
          (for I in [COND
                               (CD.OVERPAINTBITMAPS)
                               (T (SETQ CD.OVERPAINTBITMAPS (LIST (BITMAPFROMSTRING "Interlisp-D"]
             until (CD.QUITP (OR WAIT 10)) do (CD.WALKBM WINDOW I NIL SPEED)
                                                         (OR (CD.QUITP 10)
                                                             (CD.WALKBM WINDOW NIL NIL SPEED])

(CD.WALKBM
  [LAMBDA (WINDOW BM FONT SPEED)                         (* kbr%: " 3-Sep-86 18:52")
    (PROG (BITSPERPIXEL EBM SCR MAXX MAXY MAXCOLOR)
          (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW))
          (OR SPEED (SETQ SPEED 5))
          (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL))
          (SETQ EBM (CACHEBITMAP BM FONT BITSPERPIXEL))
          (SETQ SCR (BITMAPCOPY EBM))
          (SETQ MAXX (IDIFFERENCE (WINDOWPROP WINDOW 'WIDTH)
                            (BITMAPWIDTH EBM)))
          (SETQ MAXY (IDIFFERENCE (WINDOWPROP WINDOW 'HEIGHT)
                            (BITMAPHEIGHT EBM)))
          (SCREENCOLORMAP (CD.RANDCOLORMAP))
          (bind (X _ -1)
                 (Y _ -1)
                 (DX _ 0)
                 (DY _ 0)
                 (I _ 1)
                 (J _ 0)
                 (COLORCOUNTER _ 0) until (CD.QUITP) do [COND
                                                                       ((EQ I MAXCOLOR)
                                                                        (SETQ I 1))
                                                                       (T (SETQ I (ADD1 I]
                                                                   (add X DX)
                                                                   (add Y DY)
                                                                   [COND
                                                                      ((OR (ILEQ J 0)
                                                                           (ILESSP X 0)
                                                                           (IGEQ X MAXX)
                                                                           (ILESSP Y 0)
                                                                           (IGEQ Y MAXY))
                                                                       (SETQ X (RAND 0 MAXX))
                                                                       (SETQ Y (RAND 0 MAXY))
                                                                       (SETQ DX (RAND (IMINUS SPEED)
                                                                                      SPEED))
                                                                       (SETQ DY (RAND (IMINUS SPEED)
                                                                                      SPEED))
                                                                       (SETQ J (RAND CD.MINWALK 
                                                                                     CD.MAXWALK)))
                                                                      (T (SETQ J (SUB1 J]
                                                                   (OVERPAINT EBM (COLORSCREENBITMAP)
                                                                          X Y (COLORTEXTUREFROMCOLOR#
                                                                               I)
                                                                          SCR)
                                                                   (COND
                                                                      ((IGREATERP (SETQ COLORCOUNTER
                                                                                   (ADD1 COLORCOUNTER
                                                                                         ))
                                                                              300)
                                                                       (SETQ COLORCOUNTER 0)
                                                                       (SCREENCOLORMAP (
                                                                                    CD.RANDCOLORMAP
                                                                                        )))
                                                                      (T (ROTATECOLORMAP 1 MAXCOLOR))
                                                                      )
                                                                   (DISMISS 15])

(CD.RANDCOLORMAP
  [LAMBDA NIL                                            (* kbr%: " 3-Sep-86 21:16")
    (PROG (MAXCOLOR)
          (SETQ MAXCOLOR (BITSPERPIXEL (SCREENCOLORMAP)))
          (SELECTQ (RAND 1 2)
              (1 [COND
                    ((NULL CD.RANDOM.COLORMAP)
                     (SETQ CD.RANDOM.COLORMAP (COLORMAPCREATE))
                     (for COLOR from 0 to MAXCOLOR
                        do (SETA (ELT CD.RANDOM.COLORMAP COLOR)
                                     (create RGB
                                            RED _ (RAND 0 255)
                                            GREEN _ (RAND 0 255)
                                            BLUE _ (RAND 0 255]
                 (RETURN CD.RANDOM.COLORMAP))
              (2 (COND
                    ((NULL CD.RAINBOW.COLORMAP)
                     [SETQ CD.RAINBOW.COLORMAP (RAINBOWMAP (COLORMAPBITS (SCREENCOLORMAP]
                                                             (* make every 16th color random)
                     [for COLOR from (RAND 0 15) to MAXCOLOR by 16
                        do (SETA (ELT CD.RAINBOW.COLORMAP COLOR)
                                     (create RGB
                                            RED _ (RAND 0 255)
                                            GREEN _ (RAND 0 255)
                                            BLUE _ (RAND 0 255]
                     (RETURN CD.RAINBOW.COLORMAP)))
                 CD.RAINBOW.COLORMAP)
              NIL])
)

(RPAQ? CD.MAXWALK NIL)

(RPAQ? CD.MINWALK NIL)

(RPAQ? CD.RANDCOLORPROB NIL)

(RPAQ? CD.RANDOM.COLORMAP NIL)

(RPAQ? CD.RAINBOW.COLORMAP NIL)

(RPAQ? CD.8BITBMEXP (LIST (HARRAY 60)))

(RPAQ? CD.4BITBMEXP (LIST (HARRAY 60)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS CD.8BITBMEXP CD.4BITBMEXP CD.RANDOM.COLORMAP CD.RAINBOW.COLORMAP)
)



(* Kinetic demos *)

(DEFINEQ

(KINETICDEMO
  [LAMBDA (WAIT WINDOW)                                  (* kbr%: " 3-Sep-86 20:12")
                                                             (* test example (KINETICDEMO))
    (PROG (MAXCOLOR MAXX MAXY X Y)
          (WINDOWPROP WINDOW 'TITLE "KINETIC")
          (CLEARW WINDOW)
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
          (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW)))
          (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW)))
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP) do (SETQ X (RAND 0 MAXX))
                                          (SETQ Y (RAND 0 MAXY))
                                          (BLTSHADE (RAND 0 MAXCOLOR)
                                                 WINDOW X Y (RAND 2 (IDIFFERENCE MAXX X))
                                                 (RAND 2 (IDIFFERENCE MAXY Y))
                                                 (SELECTQ (RAND 0 5)
                                                     (0 'PAINT)
                                                     (1 'ERASE)
                                                     (2 'INVERT)
                                                     'REPLACE])

(CD.DEMOKINETIC
  [LAMBDA (WINDOW FIRSTCOLOR LASTCOLOR)                  (* kbr%: " 3-Sep-86 18:40")
                                                             (* test example (CD.DEMOKINETIC))
    (PROG (BITSPERPIXEL LEFT RIGHT BOTTOM TOP X Y COLOR# ROTATETIME KINROTATETIME HALFWIDTH 
                 HALFHEIGHT)
          (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW))
          (OR (COLORNUMBERP FIRSTCOLOR)
              (SETQ FIRSTCOLOR 0))
          (OR (COLORNUMBERP LASTCOLOR)
              (SETQ LASTCOLOR (MAXIMUMCOLOR BITSPERPIXEL)))
          (COND
             ((IGREATERP FIRSTCOLOR LASTCOLOR)
              (swap FIRSTCOLOR LASTCOLOR)))
          (SETQ LEFT 0)
          (SETQ RIGHT (WINDOWPROP WINDOW 'WIDTH))
          (SETQ BOTTOM 0)
          (SETQ TOP (WINDOWPROP WINDOW 'HEIGHT))
          (SETQ COLOR# FIRSTCOLOR)
          (SETQ ROTATETIME (CLOCK 0))
          (SETQ KINROTATETIME (CLOCK 0))
          (SETQ HALFWIDTH (IQUOTIENT RIGHT 2))
          (SETQ HALFHEIGHT (IQUOTIENT TOP 2))
          (BLTSHADE FIRSTCOLOR WINDOW)
      BLTLP
          [COND
             ((IGREATERP (CLOCKDIFFERENCE ROTATETIME)
                     CD.LOGOWAITTIME)                        (* cycle the colors in the logo)
              (ROTATECOLORMAP 1 (MAXIMUMCOLOR BITSPERPIXEL))
              (SETQ ROTATETIME (CLOCK0 ROTATETIME]
          [COND
             ((IGREATERP (CLOCKDIFFERENCE KINROTATETIME)
                     CD.KINWAITTIME)                         (* cycle the colors in the logo)
              (ROTATECOLORMAP FIRSTCOLOR LASTCOLOR)
              (SETQ KINROTATETIME (CLOCK0 KINROTATETIME]
          (SETQ X (RAND LEFT RIGHT))
          (SETQ Y (RAND BOTTOM TOP))
          (BLTSHADE [COND
                       ((EQ COLOR# LASTCOLOR)
                        (SETQ COLOR# FIRSTCOLOR))
                       (T (SETQ COLOR# (ADD1 COLOR#]
                 WINDOW X Y (RAND 2 (IMIN (IDIFFERENCE RIGHT X)
                                          HALFWIDTH))
                 (RAND 2 (IMIN (IDIFFERENCE TOP Y)
                               HALFHEIGHT))
                 'REPLACE)
      MOUSELP
          (COND
             ((MOUSESTATE MIDDLE)
              (SELECTQ [CAR (ERSETQ (MENU (PROGN (COND
                                                    ((NOT (TYPENAMEP CD.KINETICMENU 'MENU))
                                                     (INIT/COLORDEMO/MENUS)))
                                                 CD.KINETICMENU]
                  (EditColorMap (EDITCOLORMAP))
                  (IncreaseLogoSpeed 
                       (SETQ CD.LOGOWAITTIME (FIX (FTIMES CD.LOGOWAITTIME 0.8))))
                  (DecreaseLogoSpeed 
                       (SETQ CD.LOGOWAITTIME (FIX (FTIMES CD.LOGOWAITTIME 1.3))))
                  (IncreaseColorFlip 
                       (SETQ CD.KINWAITTIME (FIX (FTIMES CD.KINWAITTIME 0.8))))
                  (DecreaseColorFlip 
                       (SETQ CD.KINWAITTIME (FIX (FTIMES CD.KINWAITTIME 1.3))))
                  (STOP (RETURN))
                  NIL))
             ((MOUSESTATE LEFT)                              (* on left rotate colormap)
              (ROTATECOLORMAP FIRSTCOLOR LASTCOLOR)
              [COND
                 ((IGREATERP (CLOCKDIFFERENCE ROTATETIME)
                         CD.LOGOWAITTIME)                    (* cycle the colors in the logo)
                  (ROTATECOLORMAP 1 (MAXIMUMCOLOR BITSPERPIXEL))
                  (SETQ ROTATETIME (CLOCK0 ROTATETIME]
              [COND
                 ((IGREATERP (CLOCKDIFFERENCE KINROTATETIME)
                         CD.KINWAITTIME)                     (* cycle the colors in the logo)
                  (ROTATECOLORMAP FIRSTCOLOR LASTCOLOR)
                  (SETQ KINROTATETIME (CLOCK0 KINROTATETIME]
              (DISMISS (IMIN CD.KINETICWAITTIME CD.LOGOWAITTIME))
              (GO MOUSELP)))
          (GO BLTLP])

(CD.CIRKIN
  [LAMBDA (WINDOW)                                       (* kbr%: " 8-Jul-85 15:18")
    (PROG (MAXX MAXY MAXRAD MAXCOLOR)
          (WINDOWPROP WINDOW 'TITLE 'CD.CIRKIN)
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
          [SETQ MAXX (SUB1 (WINDOWPROP WINDOW 'WIDTH]
          [SETQ MAXY (SUB1 (WINDOWPROP WINDOW 'HEIGHT]
          (SETQ MAXRAD (IQUOTIENT (IMIN MAXX MAXY)
                              3))
      LP  (for I from 1 to 4 do (FILLCIRCLE (RAND 0 MAXX)
                                                       (RAND 0 MAXY)
                                                       (RAND 0 MAXRAD)
                                                       (RAND 0 MAXCOLOR)
                                                       WINDOW))
          (DSPOPERATION (SELECTQ (RAND 0 3)
                            (0 'REPLACE)
                            (1 'PAINT)
                            (2 'INVERT)
                            'ERASE)
                 WINDOW)
          (GO LP])
)

(RPAQQ CD.KINETICWAITTIME 150)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS CD.KINETICWAITTIME)
)



(* Vine demo *)

(DEFINEQ

(VINEDEMO
  [LAMBDA (WAIT WINDOW)                                  (* kbr%: " 3-Sep-86 20:12")
    (PROG (MAXX MAXY X1 Y1 DX DY X2 Y2 COLOR MAXCOLOR WIDTH MAXWIDTH)
          (WINDOWPROP WINDOW 'TITLE "VINE")
          (CLEARW WINDOW)
          (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW)))
          (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW)))
          (SETQ X1 (IQUOTIENT MAXX 2))
          (SETQ Y1 (IQUOTIENT MAXY 2))
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
          (SETQ COLOR (IQUOTIENT MAXCOLOR 2))
          (SETQ MAXWIDTH (IQUOTIENT (IMIN MAXX MAXY)
                                4))
          (SETQ WIDTH 10)
          (SETQ DX 0)
          (SETQ DY 0)
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP NIL)
             do                                          (* Update velocity.
                                                           *)
                   [SETQ DX (CD.INRANGE (IQUOTIENT (IMINUS X1)
                                                   2)
                                   (IQUOTIENT (IDIFFERENCE MAXX X1)
                                          2)
                                   (IPLUS DX (RAND (IQUOTIENT (IMINUS X1)
                                                          24)
                                                   (IQUOTIENT (IDIFFERENCE MAXX X1)
                                                          24]
                   [SETQ DY (CD.INRANGE (IQUOTIENT (IMINUS Y1)
                                                   2)
                                   (IQUOTIENT (IDIFFERENCE MAXY Y1)
                                          2)
                                   (IPLUS DY (RAND (IQUOTIENT (IMINUS Y1)
                                                          24)
                                                   (IQUOTIENT (IDIFFERENCE MAXY Y1)
                                                          24] 

         (* Knowing current (X1 Y1) and last WIDTH and COLOR, compute the point we draw 
       to (X2 Y2) and new WIDTH and COLOR. *)

                   (SETQ X2 (CD.INRANGE 0 MAXX (IPLUS X1 DX)))
                   [COND
                      ((OR (EQ X2 0)
                           (EQ X2 MAXX))
                       (SETQ DX (IMINUS DX]
                   (SETQ Y2 (CD.INRANGE 0 MAXY (IPLUS Y1 DY)))
                   [COND
                      ((OR (EQ Y2 0)
                           (EQ Y2 MAXY))
                       (SETQ DY (IMINUS DY]
                   [SETQ WIDTH
                    (CD.INRANGE 1 MAXWIDTH
                           (IPLUS WIDTH
                                  (ITIMES (CAR (NTH '(-1 0 0 0 0 0 0 1)
                                                    (RAND 1 8)))
                                         (ADD1 (IQUOTIENT WIDTH 3]
                   (SETQ COLOR
                    (IMOD [IPLUS COLOR (CAR (NTH '(-1 0 0 0 0 0 0 1)
                                                 (RAND 1 8]
                          MAXCOLOR))                         (* Drawline and update position
                                                           (X1 Y1) *)
                   (DRAWLINE X1 Y1 X2 Y2 WIDTH 'REPLACE WINDOW COLOR)
                   (SETQ X1 X2)
                   (SETQ Y1 Y2])

(CD.INRANGE
  [LAMBDA (MIN MAX VALUE)                                (* kbr%: " 4-Mar-85 14:12")
    (IMAX MIN (IMIN MAX VALUE])
)



(* Raining demo *)

(DEFINEQ

(RAINING
  [LAMBDA (WAIT WINDOW)                                  (* kbr%: " 3-Sep-86 20:12")
    (PROG (N MAXCOLOR WIDTH HEIGHT COLOR#)
          (WINDOWPROP WINDOW 'TITLE "RAINING")
          (CLEARW WINDOW)
          (SETQ N 3)
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
          (SETQ WIDTH (BITMAPWIDTH WINDOW))
          (SETQ HEIGHT (BITMAPHEIGHT WINDOW))
          (SETQ COLOR# (RAND 0 MAXCOLOR))
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP NIL) do (SETQ COLOR# (CD.DOCOLORDROP (RAND 10
                                                                                      (IDIFFERENCE
                                                                                       WIDTH 10))
                                                                   (RAND 10 (IDIFFERENCE HEIGHT 10))
                                                                   N
                                                                   (ITIMES N 3)
                                                                   8 COLOR# MAXCOLOR WINDOW])

(CD.PUTDROPS
  [LAMBDA (WINDOW N)                                     (* kbr%: " 8-Jul-85 10:53")
    (PROG (POS MAXCOLOR)
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
      LP  (SETQ POS (GETPOSITION WINDOW))
          (COND
             ((LASTMOUSESTATE RIGHT)
              (RETURN)))
          (CD.DOCOLORDROP (fetch (POSITION XCOORD) of POS)
                 (fetch (POSITION YCOORD) of POS)
                 (OR N 3)
                 (COND
                    ((LASTMOUSESTATE LEFT)
                     (RAND 8 15))
                    (T (RAND 10 20)))
                 6 0 MAXCOLOR WINDOW)
          (GO LP])

(CD.DOCOLORDROP
  [LAMBDA (X Y WIDTH RADIUSINCR NCIRCLES COLOR# MAXCOLOR WINDOW)
                                                             (* kbr%: " 8-Jul-85 10:32")
                                                             (* draws a series of concentric 
                                                           circles.)
    (for I from 1 to NCIRCLES do (DRAWCIRCLE X Y (ITIMES I RADIUSINCR)
                                                        [LIST 'ROUND WIDTH (COND
                                                                              ((ILESSP (SETQ COLOR#
                                                                                        (ADD1 COLOR#)
                                                                                        )
                                                                                      MAXCOLOR)
                                                                               COLOR#)
                                                                              (T (SETQ COLOR# 0]
                                                        NIL WINDOW))
    COLOR#])

(CD.RAININGCOLORMAP
  [LAMBDA (BITSPERPIXEL)                                 (* kbr%: " 8-Jul-85 11:13")
    (COLORMAPCREATE (SELECTQ BITSPERPIXEL
                        (4 [NCONC (LIST '(0 0 0))
                                  (for I from 100 to 255 by 50
                                     collect (LIST 0 0 I))
                                  (for I from 0 to 11
                                     collect '(0 0 0])
                        (8 [NCONC (LIST '(0 0 0))
                                  (for I from 100 to 255 by 50
                                     collect (LIST 0 0 I))
                                  (for I from 0 to 11
                                     collect '(0 0 0])
                        (\ILLEGAL.ARG BITSPERPIXEL))
           BITSPERPIXEL])
)



(* Modart demo *)

(DEFINEQ

(MODARTDEMO
  [LAMBDA (WAIT WINDOW)                                  (* kbr%: " 3-Sep-86 20:12")
    (PROG (WIDTH HEIGHT MAXCOLOR W H L B)
          (WINDOWPROP WINDOW 'TITLE "MODART")
          (CLEARW WINDOW)
          (SETQ WIDTH (BITMAPWIDTH WINDOW))
          (SETQ HEIGHT (BITMAPHEIGHT WINDOW))
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP) do (SETQ W (RAND 0 WIDTH))
                                          (SETQ H (RAND 0 HEIGHT))
                                          (SETQ L (RAND 0 (IDIFFERENCE WIDTH W)))
                                          (SETQ B (RAND 0 (IDIFFERENCE HEIGHT H)))
                                          (BITBLT WINDOW 0 0 WINDOW L B W H
                                                 (SELECTQ (RAND 0 2)
                                                     (0 'INPUT)
                                                     (1 'INVERT)
                                                     'TEXTURE)
                                                 (SELECTQ (RAND 0 3)
                                                     (0 'REPLACE)
                                                     (1 'PAINT)
                                                     (2 'INVERT)
                                                     'ERASE)
                                                 (RAND 0 MAXCOLOR])
)



(* Starburst demo *)

(DEFINEQ

(STARBURSTDEMO
  [LAMBDA (WAIT WINDOW)                                  (* kbr%: " 3-Sep-86 20:11")
    (PROG (MAXX MAXY MAXCOLOR MAXWIDTH MINWIDTH)
          (WINDOWPROP WINDOW 'TITLE "STARBURST")
          (CLEARW WINDOW)
          (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW)))
          (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW)))
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
          (SETQ MAXWIDTH (IQUOTIENT (IMIN MAXX MAXY)
                                2))
          (SETQ MINWIDTH (IQUOTIENT MAXWIDTH 6))
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP) do (CD.STARBURST MAXX MAXY MINWIDTH MAXWIDTH WINDOW])

(CD.STARBURST
  [LAMBDA (MAXX MAXY MINWIDTH MAXWIDTH WINDOW)           (* kbr%: "23-Feb-86 17:15")
    (PROG (BITSPERPIXEL NCOLORS RADIUS C S CX1 CY1 COLOR1 DELTA1 CX2 CY2 COLOR2 DELTA2 CX3 CY3 COLOR3
                 DELTA3)

         (* Do several starbursts at once to help minimize calls to COS and SIN which 
       are slow. *)

          (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW))
          (SETQ NCOLORS (ADD1 (MAXIMUMCOLOR BITSPERPIXEL)))
          (SETQ RADIUS (RAND MINWIDTH MAXWIDTH))
          [PROGN (SETQ CX1 (RAND 0 MAXX))
                 (SETQ CY1 (RAND 0 MAXY))
                 (SETQ COLOR1 (RAND 0 (SUB1 NCOLORS)))
                 (SETQ DELTA1 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL]
          [PROGN (SETQ CX2 (RAND 0 MAXX))
                 (SETQ CY2 (RAND 0 MAXY))
                 (SETQ COLOR2 (RAND 0 (SUB1 NCOLORS)))
                 (SETQ DELTA2 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL]
          [PROGN (SETQ CX3 (RAND 0 MAXX))
                 (SETQ CY3 (RAND 0 MAXY))
                 (SETQ COLOR3 (RAND 0 (SUB1 NCOLORS)))
                 (SETQ DELTA3 (EXPT 2 (RAND 0 (SUB1 BITSPERPIXEL]
          (for THETA from 0 to 44 by 5
             do (SETQ C (FTIMES RADIUS (COS THETA)))
                   (SETQ S (FTIMES RADIUS (SIN THETA)))
                   (PROGN (CD.STARSHINE CX1 CY1 C S WINDOW COLOR1)
                          (SETQ COLOR1 (IMOD (IPLUS COLOR1 DELTA1)
                                             NCOLORS)))
                   (PROGN (CD.STARSHINE CX2 CY2 C S WINDOW COLOR2)
                          (SETQ COLOR2 (IMOD (IPLUS COLOR2 DELTA2)
                                             NCOLORS)))
                   (PROGN (CD.STARSHINE CX3 CY3 C S WINDOW COLOR3)
                          (SETQ COLOR3 (IMOD (IPLUS COLOR3 DELTA3)
                                             NCOLORS])

(CD.STARSHINE
  [LAMBDA (CX1 CY1 C S WINDOW COLOR)                     (* kbr%: "23-Feb-86 16:57")
    (PROG NIL
          (DRAWLINE (IDIFFERENCE CX1 C)
                 (IDIFFERENCE CY1 S)
                 (IPLUS CX1 C)
                 (IPLUS CY1 S)
                 1
                 'REPLACE WINDOW COLOR)
          (DRAWLINE (IDIFFERENCE CX1 C)
                 (IPLUS CY1 S)
                 (IPLUS CX1 C)
                 (IDIFFERENCE CY1 S)
                 1
                 'REPLACE WINDOW COLOR)
          (DRAWLINE (IDIFFERENCE CX1 S)
                 (IPLUS CY1 C)
                 (IPLUS CX1 S)
                 (IDIFFERENCE CY1 C)
                 1
                 'REPLACE WINDOW COLOR)
          (DRAWLINE (IPLUS CX1 S)
                 (IPLUS CY1 C)
                 (IDIFFERENCE CX1 S)
                 (IDIFFERENCE CY1 C)
                 1
                 'REPLACE WINDOW COLOR])
)



(* Peano demo *)


(FILESLOAD (FROM LISPUSERS)
       PEANO)
(DEFINEQ

(COLORPEANODEMO
  [LAMBDA (WAIT WINDOW)                                  (* kbr%: " 3-Sep-86 20:13")
    (PROG (BITSPERPIXEL MAXCOLOR MAXSHADE LEVEL SCALE)
          (WINDOWPROP WINDOW 'TITLE "PEANO")
          (SETQ BITSPERPIXEL (BITSPERPIXEL WINDOW))
          (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL))
          (SETQ MAXSHADE (MAXIMUMSHADE BITSPERPIXEL))
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP) do (DSPCOLOR (RAND 0 MAXCOLOR)
                                                  WINDOW)
                                          (DSPTEXTURE (RAND 0 MAXSHADE)
                                                 WINDOW)
                                          (DSPBACKCOLOR (RAND 0 MAXCOLOR)
                                                 WINDOW)
                                          (SETQ LEVEL (RAND 4 6))
                                          (SETQ SCALE (IQUOTIENT (IMAX (BITMAPWIDTH WINDOW)
                                                                       (BITMAPHEIGHT WINDOW))
                                                             (EXPT 2 LEVEL)))
                                          (SETQ PEANOWINDOW WINDOW)
                                          (PEANODEMO LEVEL SCALE])
)



(* Bubble demo *)

(DEFINEQ

(BUBBLEDEMO
  [LAMBDA (WAIT WINDOW)                                  (* kbr%: " 3-Sep-86 20:13")
    (PROG (MAXX MAXY MAXCOLOR MAXWIDTH MINWIDTH HOLLOW)
          (WINDOWPROP WINDOW 'TITLE "BUBBLE")
          (CLEARW WINDOW)
          (SETQ MAXX (SUB1 (BITMAPWIDTH WINDOW)))
          (SETQ MAXY (SUB1 (BITMAPHEIGHT WINDOW)))
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
          (SETQ MAXWIDTH (IQUOTIENT (IMIN MAXX MAXY)
                                8))
          (SETQ MINWIDTH (IQUOTIENT MAXWIDTH 6))
          (COND
             ((EQ (RAND 0 1)
                  1)
              (SETQ HOLLOW T)))
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP NIL) do (CD.BUBBLE (RAND 0 MAXX)
                                                      (RAND 0 MAXY)
                                                      (RAND MINWIDTH MAXWIDTH)
                                                      HOLLOW WINDOW])

(CD.BUBBLE
  [LAMBDA (CENTERX CENTERY RADIUS HOLLOW WINDOW)         (* kbr%: "29-Jul-85 18:09")
    (PROG (MAXCOLOR)
          (SETQ MAXCOLOR (MAXIMUMCOLOR (BITSPERPIXEL WINDOW)))
          (FILLCIRCLE CENTERX CENTERY RADIUS (RAND 0 MAXCOLOR)
                 WINDOW)
          (COND
             (HOLLOW (FILLCIRCLE CENTERX CENTERY (SUB1 RADIUS)
                            0 WINDOW])
)



(* Overpaint demo *)

(DEFINEQ

(OVERPAINTDEMO
  [LAMBDA (WAIT)                                         (* kbr%: " 3-Sep-86 20:14")
    (PROG (BITMAP BITSPERPIXEL MAXCOLOR WIDTH HEIGHT X Y)
          (WINDOWPROP CD.WINDOW1 'TITLE "MASK")
          (WINDOWPROP CD.WINDOW2 'TITLE "BACKGROUND")
          (WINDOWPROP CD.WINDOW3 'TITLE "INPUT")
          (WINDOWPROP CD.WINDOW4 'TITLE "OUTPUT")
          (SETQ BITSPERPIXEL (BITSPERPIXEL CD.WINDOW1))
          (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL))
          (SETQ WIDTH (BITMAPWIDTH CD.WINDOW1))
          (SETQ HEIGHT (BITMAPHEIGHT CD.WINDOW1))
          [COND
             ((NULL CD.OVERPAINTBITMAPS)
              (SETQ CD.OVERPAINTBITMAPS (for STRING in '("Interlisp-D" "Xerox" "Color")
                                           collect (BITMAPFROMSTRING STRING (FONTCREATE
                                                                                 'TIMESROMAND 36)
                                                              BITSPERPIXEL]
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP)
             do (BITBLT CD.WINDOW2 NIL NIL CD.WINDOW4)
                   (for I from 1 to (RAND 6 20)
                      do (SETQ BITMAP (CD.NEXTELEMENT BITMAP CD.OVERPAINTBITMAPS))
                            [SETQ X (RAND 0 (IDIFFERENCE WIDTH (BITMAPWIDTH BITMAP]
                            [SETQ Y (RAND 0 (IDIFFERENCE HEIGHT (BITMAPHEIGHT BITMAP]
                            (CLEARW CD.WINDOW1)
                            (BITBLT BITMAP NIL NIL CD.WINDOW1 X Y)
                            (BLTSHADE (RAND 0 MAXCOLOR)
                                   CD.WINDOW3)
                            (BITBLT CD.WINDOW1 NIL NIL CD.WINDOW3 NIL NIL NIL NIL 'INVERT
                                   'ERASE)
                            (BITBLT CD.WINDOW1 NIL NIL CD.WINDOW4 NIL NIL NIL NIL 'INPUT 'ERASE)
                            (BITBLT CD.WINDOW3 NIL NIL CD.WINDOW4 NIL NIL NIL NIL 'INPUT 'PAINT])
)

(RPAQQ CD.OVERPAINTBITMAPS NIL)



(* Tile demo *)


(RPAQ? CD.TILEBITMAPS NIL)
(DEFINEQ

(TILEDEMO
  [LAMBDA (WAIT)                                         (* kbr%: " 3-Sep-86 21:19")
    (PROG (WINDOWS WINDOW BITSPERPIXEL BITMAP)
          (SETQ WINDOWS (LIST CD.WINDOW1 CD.WINDOW2 CD.WINDOW3 CD.WINDOW4))
          [COND
             ((ILESSP (LENGTH CD.TILEBITMAPS)
                     4)
              (SETQ BITSPERPIXEL (BITSPERPIXEL (COLORSCREENBITMAP)))
              (for WINDOW in WINDOWS do (SETQ BITMAP (BITMAPCREATE 100 100 BITSPERPIXEL))
                                                   (BITBLT WINDOW NIL NIL BITMAP)
                                                   (push CD.TILEBITMAPS BITMAP]
          (CHANGEBACKGROUND (CD.RANDELEMENT CD.TILEBITMAPS)
                 (COLORSCREEN))
          (WINDOWPROP CD.WINDOW1 'TITLE "WINDOW1")
          (WINDOWPROP CD.WINDOW2 'TITLE "WINDOW2")
          (WINDOWPROP CD.WINDOW3 'TITLE "WINDOW3")
          (WINDOWPROP CD.WINDOW4 'TITLE "WINDOW4")
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP) do (SETQ WINDOW (CD.NEXTELEMENT WINDOW WINDOWS))
                                          (SETQ BITMAP (CD.RANDELEMENT CD.TILEBITMAPS))
                                          (TILE BITMAP WINDOW])
)



(* Polygons demo *)


(FILESLOAD (FROM LISPUSERS)
       COLORPOLYGONS)
(DEFINEQ

(POLYGONSDEMO
  [LAMBDA (WAIT)                                         (* kbr%: " 6-Jun-86 00:27")
    (PROG NIL
          (CD.QUITP (OR WAIT 120))
          (until (CD.QUITP NIL) do (COLORPOLYGON CD.WINDOW1)
                                              (COLORPOLYGON CD.WINDOW2)
                                              (COLORPOLYGON CD.WINDOW3)
                                              (COLORPOLYGON CD.WINDOW4)
                                              (COLORPOLYGONS.ROTATECOLORMAP])
)

(FILESLOAD COLOR)



(* Color font profile *)


(RPAQQ COLORFONTPROFILE
       ((DEFAULTFONT 1 (GACHA 10)
               (GACHA 8)
               (TERMINAL 8)
               (4DISPLAY (GACHA 10 MRR-WHITE-RED))
               (8DISPLAY (GACHA 10 MRR-WHITE-RED))
               (24DISPLAY (GACHA 10 MRR-WHITE-RED)))
        (BOLDFONT 2 (HELVETICA 10 BRR)
               (HELVETICA 8 BRR)
               (MODERN 8 BRR)
               (4DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))
               (8DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA))
               (24DISPLAY (HELVETICA 10 BRR-WHITE-MAGENTA)))
        (LITTLEFONT 3 (HELVETICA 8)
               (HELVETICA 6 MIR)
               (MODERN 8 MIR)
               (4DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))
               (8DISPLAY (HELVETICA 8 MRR-WHITE-GREEN))
               (24DISPLAY (HELVETICA 8 MRR-WHITE-GREEN)))
        (BIGFONT 4 (HELVETICA 12 BRR)
               (HELVETICA 10 BRR)
               (MODERN 10 BRR)
               (4DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))
               (8DISPLAY (HELVETICA 12 BRR-WHITE-BLUE))
               (24DISPLAY (HELVETICA 12 BRR-WHITE-BLUE)))
        (USERFONT BOLDFONT)
        (COMMENTFONT LITTLEFONT)
        (LAMBDAFONT BIGFONT)
        (SYSTEMFONT)
        (CLISPFONT BOLDFONT)
        (CHANGEFONT)
        (PRETTYCOMFONT BOLDFONT)
        (FONT1 DEFAULTFONT)
        (FONT2 BOLDFONT)
        (FONT3 LITTLEFONT)
        (FONT4 BIGFONT)
        (FONT5 5 (HELVETICA 10 BIR)
               (HELVETICA 8 BIR)
               (MODERN 8 BIR))
        (FONT6 6 (HELVETICA 10 BRR)
               (HELVETICA 8 BRR)
               (MODERN 8 BRR))
        (FONT7 7 (GACHA 12)
               (GACHA 12)
               (TERMINAL 12))))

(FONTPROFILE COLORFONTPROFILE)

                                                             (* Create color fonts now instead of 
                                                           later. COLOR should already be 
                                                           LOADed. *)

(for FONTCLASS in (LIST DEFAULTFONT BOLDFONT LITTLEFONT BIGFONT)
   do (FONTCREATE FONTCLASS NIL NIL NIL '8DISPLAY))

(FONTCREATE 'TIMESROMAND 36 NIL NIL NIL '8DISPLAY)
(PUTPROPS COLORDEMO COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4477 14158 (COLORDEMO 4487 . 6282) (CD.INIT 6284 . 6499) (CD.INIT.COLORMAPS 6501 . 8371
) (CD.INIT.WINDOWS 8373 . 12458) (CD.INIT.MENU 12460 . 12770) (CD.NEXTELEMENT 12772 . 13305) (
CD.RANDELEMENT 13307 . 13461) (CD.CHOOSEDEMO 13463 . 13617) (CD.QUITP 13619 . 14156)) (14186 16102 (
CD.MINESHAFT 14196 . 15454) (CD.POINTTEST 15456 . 16100)) (16103 20567 (WELLDEMO 16113 . 16701) (
TUNNELDEMO 16703 . 17285) (CD.SQUARETUNNEL 17287 . 18892) (CD.CIRCULARTUNNEL 18894 . 20565)) (20592 
21003 (CD.ROTATEIT 20602 . 21001)) (21004 23542 (COLORMAPOF 21014 . 21405) (COLORMAPCOPY 21407 . 21915
) (COLORFILL 21917 . 22864) (COLORBACKGROUND 22866 . 23024) (COLORFILLAREA 23026 . 23540)) (23566 
29925 (WALKDEMO 23576 . 24222) (CD.WALKBM 24224 . 28377) (CD.RANDCOLORMAP 28379 . 29923)) (30323 36512
 (KINETICDEMO 30333 . 31545) (CD.DEMOKINETIC 31547 . 35463) (CD.CIRKIN 35465 . 36510)) (36643 40114 (
VINEDEMO 36653 . 39970) (CD.INRANGE 39972 . 40112)) (40142 43978 (RAINING 40152 . 41258) (CD.PUTDROPS 
41260 . 41927) (CD.DOCOLORDROP 41929 . 43103) (CD.RAININGCOLORMAP 43105 . 43976)) (44005 45460 (
MODARTDEMO 44015 . 45458)) (45490 48976 (STARBURSTDEMO 45500 . 46174) (CD.STARBURST 46176 . 48055) (
CD.STARSHINE 48057 . 48974)) (49049 50326 (COLORPEANODEMO 49059 . 50324)) (50353 51732 (BUBBLEDEMO 
50363 . 51331) (CD.BUBBLE 51333 . 51730)) (51762 53772 (OVERPAINTDEMO 51772 . 53770)) (53866 55118 (
TILEDEMO 53876 . 55116)) (55202 55744 (POLYGONSDEMO 55212 . 55742)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/COLORDEMO.TEDIT b/internal/library/OBSOLETE/COLORDEMO.TEDIT
new file mode 100644
index 00000000..e4b388c0
Binary files /dev/null and b/internal/library/OBSOLETE/COLORDEMO.TEDIT differ
diff --git a/internal/library/OBSOLETE/COLORFONTHACK b/internal/library/OBSOLETE/COLORFONTHACK
new file mode 100644
index 00000000..44d5cf2b
--- /dev/null
+++ b/internal/library/OBSOLETE/COLORFONTHACK
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 12:33:48" |{DSK}<usr>local>lde>lispcore>internal>library>COLORFONTHACK.;2| 2214   

      |changes| |to:|  (VARS COLORFONTHACKCOMS)

      |previous| |date:| " 6-Dec-88 21:52:32" 
|{DSK}<usr>local>lde>lispcore>internal>library>COLORFONTHACK.;1|)


; Copyright (c) 1990 by Venue.  All rights reserved.

(PRETTYCOMPRINT COLORFONTHACKCOMS)

(RPAQQ COLORFONTHACKCOMS ((FNS COLORFONTHACK)))
(DEFINEQ

(COLORFONTHACK
  (LAMBDA NIL                                            (* \; "Edited  6-Dec-88 21:46 by shih")

    (* |;;| "Run through all the  color fonts, replacing their bitmaps with appropriate ones.")

    (* |;;| "Should be run *after* (COLORDISPLAY 'ON) is called.")

    (* |;;| "")

    (LET (FONTS FONTDESC CSINFO CSBITMAP NEWBM)
         (SETQ FONTS (FONTSAVAILABLE '* '* '* 0 '8DISPLAY))
         (FOR FONT IN FONTS DO (SETQ FONTDESC (FONTCREATE FONT))
                                          (SETQ CSINFO (\\GETCHARSETINFO 0 FONTDESC))
                                          (SETQ CSBITMAP (FETCH (CHARSETINFO CHARSETBITMAP)
                                                            OF CSINFO))
                                          (IF (NEQ 8 (BITSPERPIXEL CSBITMAP))
                                              THEN (SETQ NEWBM (BITMAPCREATE (BITMAPWIDTH 
                                                                                        CSBITMAP)
                                                                          (BITMAPHEIGHT CSBITMAP)
                                                                          8)) 

                                                    (* |;;| 
                                          "Bitblt knows how to coerce a 1 bppixel to an 8 bppixel.")

                                                    (BITBLT CSBITMAP NIL NIL NEWBM)
                                                    (REPLACE (CHARSETINFO CHARSETBITMAP)
                                                       OF CSINFO WITH NEWBM))))))
)
(PUTPROPS COLORFONTHACK COPYRIGHT ("Venue" 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (477 2141 (COLORFONTHACK 487 . 2139)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/COLORNNCC.TEDIT b/internal/library/OBSOLETE/COLORNNCC.TEDIT
new file mode 100644
index 00000000..46174f4c
Binary files /dev/null and b/internal/library/OBSOLETE/COLORNNCC.TEDIT differ
diff --git a/internal/library/OBSOLETE/COLOROBJ b/internal/library/OBSOLETE/COLOROBJ
new file mode 100644
index 00000000..f6f987b1
--- /dev/null
+++ b/internal/library/OBSOLETE/COLOROBJ
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "14-Jun-90 21:02:08" {DSK}<usr>local>lde>lispcore>internal>library>COLOROBJ.;2 7921   

      changes to%:  (FNS COLOROBJ.IMAGEBOXFN COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN
                         COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN)
                    (VARS COLOROBJCOMS)

      previous date%: " 4-Feb-87 23:58:42" {DSK}<usr>local>lde>lispcore>internal>library>COLOROBJ.;1
)


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

(PRETTYCOMPRINT COLOROBJCOMS)

(RPAQQ COLOROBJCOMS
       [(FNS * COLOROBJFNS)
        (FILES COLOR)
        (INITVARS (COLOROBJ.DEFAULT.COLOR 'RED))
        (VARS (COLOROBJFNS '(COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN 
                                   COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN))
              (COLOROBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION COLOROBJ.DISPLAYFN)
                                        (FUNCTION COLOROBJ.IMAGEBOXFN)
                                        (FUNCTION COLOROBJ.PUTFN)
                                        (FUNCTION COLOROBJ.GETFN)
                                        (FUNCTION COLOROBJ.COPYFN)
                                        (FUNCTION COLOROBJ.BUTTONEVENTFN)
                                        (FUNCTION NILL)
                                        (FUNCTION NILL)
                                        (FUNCTION NILL)
                                        (FUNCTION NILL)
                                        (FUNCTION NILL)
                                        (FUNCTION COLOROBJ.WHENOPERATEDONFN)
                                        (FUNCTION NILL])

(RPAQQ COLOROBJFNS (COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN 
                              COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN))
(DEFINEQ

(COLOROBJ.CREATE
  [LAMBDA (COLOR)                                        (* gbn "13-Jan-86 16:00")

         (* * create a color object. color is anything acceptable to dspcolor
       (atoms on colornames, rgb triples, indices))

    (LET ((COLOROBJ (IMAGEOBJCREATE NIL COLOROBJ.IMAGEFNS)))
         (IMAGEOBJPROP COLOROBJ 'COLOR (OR COLOR COLOROBJ.DEFAULT.COLOR))
         COLOROBJ])

(COLOROBJ.DISPLAYFN
  [LAMBDA (COLOROBJ IMAGE.STREAM)                        (* gbn "13-Jan-86 17:51")

         (* On the display a color object shows up as the color name, otherwise it has 
       no image. On any stream it has the sideeffect of changing the foreground color)

    (LET* ((COLOR (IMAGEOBJPROP COLOROBJ 'COLOR))
           (X (DSPXPOSITION NIL IMAGE.STREAM))
           (Y (DSPYPOSITION NIL IMAGE.STREAM)))
          (DSPCOLOR COLOR IMAGE.STREAM)
          (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM)
              (DISPLAY (DSPFONT '(WEIGHT BOLD)
                              IMAGE.STREAM)
                       (LET* ((STRING (IMAGEOBJPROP COLOROBJ 'COLOR))
                              (STRINGREGION (STRINGREGION STRING IMAGE.STREAM))
                              (LEFT (ADD1 (fetch (REGION LEFT) of STRINGREGION)))
                              (BOTTOM (fetch (REGION BOTTOM) of STRINGREGION))
                              (REGION (create REGION
                                             LEFT _ LEFT
                                             BOTTOM _ BOTTOM
                                             HEIGHT _ (IPLUS (fetch (REGION HEIGHT) of 
                                                                                         STRINGREGION
                                                                    )
                                                             2)
                                             WIDTH _ (IPLUS (fetch (REGION WIDTH) of 
                                                                                         STRINGREGION
                                                                   )
                                                            6)))
                              (TOP (fetch (REGION TOP) of REGION))
                              (RIGHT (fetch (REGION RIGHT) of REGION)))
                             (IMAGEOBJPROP COLOROBJ 'REGION REGION)
                             (CENTERPRINTINREGION STRING REGION IMAGE.STREAM)
                             (DRAWLINE LEFT BOTTOM LEFT (SUB1 TOP)
                                    1
                                    'INVERT IMAGE.STREAM)
                             (DRAWLINE LEFT TOP (SUB1 RIGHT)
                                    TOP 1 'INVERT IMAGE.STREAM)
                             (DRAWLINE RIGHT TOP RIGHT (ADD1 BOTTOM)
                                    1
                                    'INVERT IMAGE.STREAM)
                             (DRAWLINE RIGHT BOTTOM (ADD1 LEFT)
                                    BOTTOM 1 'INVERT IMAGE.STREAM)))
              (NILL])

(COLOROBJ.GETFN
  [LAMBDA (INPUT.STREAM TEXTSTREAM)                      (* gbn "13-Jan-86 15:42")
                                                             (* reads the COLOR and creates an 
                                                           COLOROBJ)
    (COLOROBJ.CREATE (READ INPUT.STREAM])

(COLOROBJ.IMAGEBOXFN
  [LAMBDA (COLOROBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* gbn "13-Jan-86 16:01")

         (* * Returns a null imagebox, except to the display, where it returns the size 
       of the box)

    (LET NIL (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM)
                 (DISPLAY (create IMAGEBOX
                                 XSIZE _ (IPLUS (STRINGWIDTH (IMAGEOBJPROP COLOROBJ 'COLOR)
                                                       (DSPFONT NIL IMAGE.STREAM))
                                                8)
                                 YSIZE _ (IPLUS (FONTHEIGHT (DSPFONT NIL IMAGE.STREAM))
                                                4)
                                 YDESC _ 4
                                 XKERN _ 0))
                 (create IMAGEBOX
                        XSIZE _ 0
                        YSIZE _ 0
                        YDESC _ 0
                        XKERN _ 0])

(COLOROBJ.PUTFN
  [LAMBDA (COLOROBJ OUTPUT.STREAM)                       (* gbn "13-Jan-86 15:57")
                                                             (* prints only the color to the file)
    (PRINT (IMAGEOBJPROP COLOROBJ 'COLOR)
           OUTPUT.STREAM])

(COLOROBJ.COPYFN
  [LAMBDA (IMAGEOBJ FROMSTREAM TOSTREAM)                 (* gbn "13-Jan-86 15:58")
    (COLOROBJ.CREATE (IMAGEOBJPROP IMAGEOBJ 'COLOR)
           TOSTREAM])

(COLOROBJ.WHENOPERATEDONFN
  [LAMBDA (A B C C)                                      (* gbn " 6-Jan-85 13:23")
                                                             (* DUMMY)
    ])
)

(FILESLOAD COLOR)

(RPAQ? COLOROBJ.DEFAULT.COLOR 'RED)

(RPAQQ COLOROBJFNS (COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN 
                              COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN))

(RPAQ COLOROBJ.IMAGEFNS
      (IMAGEFNSCREATE (FUNCTION COLOROBJ.DISPLAYFN)
             (FUNCTION COLOROBJ.IMAGEBOXFN)
             (FUNCTION COLOROBJ.PUTFN)
             (FUNCTION COLOROBJ.GETFN)
             (FUNCTION COLOROBJ.COPYFN)
             (FUNCTION COLOROBJ.BUTTONEVENTFN)
             (FUNCTION NILL)
             (FUNCTION NILL)
             (FUNCTION NILL)
             (FUNCTION NILL)
             (FUNCTION NILL)
             (FUNCTION COLOROBJ.WHENOPERATEDONFN)
             (FUNCTION NILL)))
(PUTPROPS COLOROBJ COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1964 7057 (COLOROBJ.CREATE 1974 . 2380) (COLOROBJ.DISPLAYFN 2382 . 5080) (
COLOROBJ.GETFN 5082 . 5411) (COLOROBJ.IMAGEBOXFN 5413 . 6375) (COLOROBJ.PUTFN 6377 . 6659) (
COLOROBJ.COPYFN 6661 . 6850) (COLOROBJ.WHENOPERATEDONFN 6852 . 7055)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/COLOROBJ.TEDIT b/internal/library/OBSOLETE/COLOROBJ.TEDIT
new file mode 100644
index 00000000..9be15d91
Binary files /dev/null and b/internal/library/OBSOLETE/COLOROBJ.TEDIT differ
diff --git a/internal/library/OBSOLETE/COLOROBJ.dfasl b/internal/library/OBSOLETE/COLOROBJ.dfasl
new file mode 100644
index 00000000..e6221842
Binary files /dev/null and b/internal/library/OBSOLETE/COLOROBJ.dfasl differ
diff --git a/internal/library/OBSOLETE/COMMON-LISP-PACKAGE b/internal/library/OBSOLETE/COMMON-LISP-PACKAGE
new file mode 100644
index 00000000..36cb0224
--- /dev/null
+++ b/internal/library/OBSOLETE/COMMON-LISP-PACKAGE
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED " 2-Feb-91 14:33:36" |{DSK}<usr>local>lde>lispcore>sources2>COMMON-LISP-PACKAGE.;7| 7002   

      |changes| |to:|  (VARIABLES OLDCLSYMS *COMMON-LISP-PACKAGE*) (VARS COMMON-LISP-PACKAGECOMS) (FUNCTIONS CRUNCH-FILES CREATE-CL-PACKAGE)

      |previous| |date:| " 2-Feb-91 13:17:24" 
|{DSK}<usr>local>lde>lispcore>sources2>COMMON-LISP-PACKAGE.;5|)


; Copyright (c) 1991 by Venue Corporation.  All rights reserved.

(PRETTYCOMPRINT COMMON-LISP-PACKAGECOMS)

(RPAQQ COMMON-LISP-PACKAGECOMS ((VARIABLES *COMMON-LISP-PACKAGE* NEWCLSYMS OLDCLSYMS SPLITCLSYMS) (FUNCTIONS CRUNCH-FILES FLIP-CL CREATE-CL-PACKAGE)))

(DEFGLOBALVAR *COMMON-LISP-PACKAGE* NIL "Place holder for the COMMON-LISP package variable")

(LISP:DEFPARAMETER NEWCLSYMS (QUOTE ("REAL" "BASE-CHARACTER" "EXTENDED-CHARACTER" "READTABLE-CASE" "SIMPLE-STRING" "BASE-STRING" "SIMPLE-BASE-STRING" "BROADCAST-STREAM" "CONCATENATED-STREAM" "ECHO-STREAM" "SYNONYM-STREAM" "STRING-STREAM" "FILE-STREAM" "TWO-WAY-STREAM" "UPGRADED-ARRAY-ELEMENT-TYPE" "UPGRADED-COMPLEX-PART-TYPE" "LOAD-TIME-EVAL" "REALP" "FDEFINITION" "NTH-VALUE" "DESTRUCTURING-BIND" "DEFINE-COMPILER-MACRO" "COMPILER-MACRO-FUNCTION" "COMPILER-MACROEXPAND" "COMPILER-MACROEXPAND-1" "VARIABLE-INFORMATION" "FUNCTION-INFORMATION" "DECLARATION-INFORMATION" "AUGMENT-ENVIRONMENT" "DEFINE-DECLARATION" "PARSE-MACRO" "ENCLOSE" "DECLAIM" "DYNAMIC-EXTENT" "*GENSYM-COUNTER*" "DELETE-PACKAGE" "DEFPACKAGE" "WITH-PACKAGE-ITERATOR" "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "COMPLEMENT" "MAP-INTO" "WITH-HASH-TABLE-ITERATOR" "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD" "HASH-TABLE-SIZE" "HASH-TABLE-TEST" "ROW-MAJOR-AREF" "OPEN-STREAM-P" "BROADCAST-STREAM-STREAMS" "CONCATENATED-STREAM-STREAMS" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "SYNONYM-STREAM-SYMBOL" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "INTERACTIVE-STREAM-P" "STREAM-EXTERNAL-FORMAT" "*READ-EVAL*" "READTABLE-CASE" "*PRINT-READABLY*" "WITH-STANDARD-IO-SYNTAX" "PRINT-UNREADABLE-OBJECT" "WILD-PATHNAME-P" "PATHNAME-MATCH-P" "TRANSLATE-PATHNAME" "LOGICAL-PATHNAME" "TRANSLATE-LOGICAL-PATHNAME" "LOGICAL-PATHNAME-TRANSLATIONS" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "COMPILE-FILE-PATHNAME" "FILE-STRING-LENGTH" "*LOAD-PRINT*" "*LOAD-PATHNAME*" "*LOAD-TRUENAME*" "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS" "*COMPILE-VERBOSE" "*COMPILE-PRINT*" "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*" "LOAD-TIME-VALUE" "FUNCTION-LAMBDA-EXPRESSION" "WITH-COMPILATION-UNIT")))

(LISP: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")

(LISP:DEFPARAMETER SPLITCLSYMS (QUOTE ("LOCALLY" "IN-PACKAGE")))

(LISP:DEFUN CRUNCH-FILES (FL) (LISP:WHEN (AND FL (LISP:SYMBOLP FL)) (LISP:SETQ FL (LIST FL))) (LISP:DOLIST (F FL) (LISP:FORMAT T "Crunching ~a~%" F) (FLIP-CL :LISP) (LOAD F (QUOTE ALLPROP)) (FLIP-CL :NOWHERE) (MAKEFILE F (QUOTE NEW)) (LISP:IF (LISP:PROBE-FILE (CONCAT F ".DFASL")) (LISP:COMPILE-FILE F) (FAKE-COMPILE-FILE F)) (LISP:FORMAT T "Done crunching ~a~%" F)))

(LISP:DEFUN FLIP-CL (WHERE) (LISP:ECASE WHERE (:LISP (LISP:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" NIL NIL) (LISP:RENAME-PACKAGE *LISP-PACKAGE* "LISP" (QUOTE ("CL")) "CL")) (:COMMON-LISP (LISP:RENAME-PACKAGE *LISP-PACKAGE* "LISP" NIL NIL) (LISP:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" (QUOTE ("CL")) "CL")) (:NOWHERE (LISP:RENAME-PACKAGE *LISP-PACKAGE* "LISP" NIL NIL) (LISP:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" NIL NIL))))

(LISP:DEFUN CREATE-CL-PACKAGE NIL (* |;;| "First, rename the LISP package to get its nicknames out of our way") (LISP:RENAME-PACKAGE (LISP:FIND-PACKAGE "LISP") "LISP" NIL NIL) (* |;;| "Then create the COMMON-LISP package and friends") (LISP:UNLESS (LISP: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* (LISP:MAKE-PACKAGE "COMMON-LISP" :USE NIL)) (* |;;| "We probably want to have COMMON-LISP-USER use XCL; this needs to be discussed") (LISP:MAKE-PACKAGE "COMMON-LISP-USER" :USE (QUOTE ("COMMON-LISP")))) (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") (LISP:DOLIST (I OLDCLSYMS) (PUT (LISP:FIND-SYMBOL I *LISP-PACKAGE*) WEIRDTAG OLDPROP)) (LISP:DOLIST (I SPLITCLSYMS) (PUT (LISP:FIND-SYMBOL I *LISP-PACKAGE*) WEIRDTAG UNSHAREDPROP)) (* |;;| "OK, crunch the external symbols in LISP.  We may eventually rehome these symbols into COMMON-LISP") (LISP: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 (LISP:INTERN (LISP:SYMBOL-NAME I) *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*) (REMPROP I WEIRDTAG)) ((NULL WEIRD?) (* \; "Share symbol; if it's already there, shadow it") (LISP:IF (SETQ S (LISP:FIND-SYMBOL (LISP:SYMBOL-NAME I) *COMMON-LISP-PACKAGE*)) (LISP:UNLESS (EQ S I) (LISP: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?)))))) (* |;;| "Hose out the new COMMON-LISP symbols") (LISP:DOLIST (I NEWCLSYMS) (EXPORT (LISP:INTERN I *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*)) (* |;;| "If these other packages are around, grab their symbols") (LET (P S) (LISP:WHEN (SETQ P (LISP:FIND-PACKAGE "XP")) (LISP: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 (LISP: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") (LISP:WHEN (SETQ P (LISP:FIND-PACKAGE "CONDITIONS")) (LISP:DO-EXTERNAL-SYMBOLS (I P) (IMPORT I *COMMON-LISP-PACKAGE*) (EXPORT I *COMMON-LISP-PACKAGE*))) (FLIP-CL :COMMON-LISP))))
(PUTPROPS COMMON-LISP-PACKAGE COPYRIGHT ("Venue Corporation" 1991))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/COPRFIX b/internal/library/OBSOLETE/COPRFIX
new file mode 100644
index 00000000..ba4a0b74
--- /dev/null
+++ b/internal/library/OBSOLETE/COPRFIX
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "12-Jun-90 18:10:37" |{DSK}<usr>local>lde>lispcore>internal>COPRFIX.;1| 1909   

      |changes| |to:|  (FNS FIX-FILE)

      |previous| |date:| "11-Jun-90 13:13:14" |{DSK}<users>sybalsky>COPRFIX.;3|)


; Copyright (c) 1990 by John Sybalsky.  All rights reserved.

(PRETTYCOMPRINT COPRFIXCOMS)

(RPAQQ COPRFIXCOMS ((FNS FIX-COPYRIGHT FIX-FILE-COPYRIGHT FIX-FILE QUALIFY-FIELDS)))
(DEFINEQ

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

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

(FIX-FILE
  (LAMBDA (FILE RECORD-NAMES)                          (* \; "Edited 11-Jun-90 17:49 by mitani")

    (* |;;| "Perform cleanup tasks on FILE.")

    (LOAD FILE 'PROP)
    (LOADCOMP FILE 'PROP)
    (FIX-COPYRIGHT FILE)
    (AND (FILEFNSLST FILE)
         (|for| RECNAME |in| RECORD-NAMES |do| (QUALIFY-FIELDS RECNAME FILE)))
    (MARKASCHANGED FILE 'FILES)
    (APPLY* 'CLEANUP FILE)))

(QUALIFY-FIELDS
  (LAMBDA (RECNAME FILE)                                 (* \; "Edited 28-Sep-87 14:41 by bvm:")
    (APPLY* 'EDITFNS FILE `(LPQ F ((*ANY* FETCH |fetch| REPLACE |replace| FFETCH |ffetch| FREPLACE 
                                          |freplace| /REPLACE |/replace|)
                                   (*ANY* ,@(APPEND (RECORDFIELDNAMES RECNAME)))
                                   --)
                                2
                                (MBD ,RECNAME)
                                0 P))))
)
(PUTPROPS COPRFIX COPYRIGHT ("John Sybalsky" 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (460 1834 (FIX-COPYRIGHT 470 . 697) (FIX-FILE-COPYRIGHT 699 . 859) (FIX-FILE 861 . 1291)
 (QUALIFY-FIELDS 1293 . 1832)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/DORADOCOLOR b/internal/library/OBSOLETE/DORADOCOLOR
new file mode 100644
index 00000000..06d3450f
--- /dev/null
+++ b/internal/library/OBSOLETE/DORADOCOLOR
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 13:56:37" {DSK}<usr>local>lde>lispcore>internal>library>DORADOCOLOR.;2 16864  

      changes to%:  (VARS DORADOCOLORCOMS)

      previous date%: "24-Feb-86 12:32:26" 
{DSK}<usr>local>lde>lispcore>internal>library>DORADOCOLOR.;1)


(* ; "
Copyright (c) 1985, 1900, 1986, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT DORADOCOLORCOMS)

(RPAQQ DORADOCOLORCOMS
       [(* * DORADOCOLOR -- Dorado machine dependent color display fns -- By Richard Burton, Herb 
           Jellinek, and Kelly Roach.)
        (DECLARE%: DONTCOPY (RECORDS MonitorCB ChannelCB ColorCB ColorEntry)
               (CONSTANTS (DORADO\COLORSCREENWIDTH 640)
                      (DORADO\COLORSCREENHEIGHT 480)
                      (DORADOCOLORPAGES 602)
                      (pplOffset 255)
                      (MCBPtr 268)
                      (MCBSeal 65326)
                      (MCBLow 160)
                      (MCBSize 8)
                      (AFlagsMask 4)
                      (ChCBLow 168)
                      (ChCBSize 8)
                      (ColCBLow 176)
                      (ColCBSize 16)
                      (CMapPages 8)))
        (* * \DORADOCOLOR.LEFTMARGIN should be set to 80 for small CONRACs, 56 for large CONRACs, and
           40 for most other monitors. *)
        (INITVARS (\DORADOCOLOR.LEFTMARGIN 80)
               (\DORADOCOLOR.ATABLEIMAGE NIL)
               (DORADOCOLOR.BITSPERPIXEL 8))
        (GLOBALVARS \DORADOCOLOR.ATABLEIMAGE \DORADOCOLOR.LEFTMARGIN DORADOCOLOR.BITSPERPIXEL)
        (FNS \RGB.TO.DORADO.RGB \DORADOCOLOR.LOOKATA)
        (FNS \DORADOCOLOR.INIT \DORADOCOLOR.STARTCOLOR \DORADOCOLOR.STOPCOLOR \DORADOCOLOR.EVENTFN 
             \DORADOCOLOR.SENDCOLORMAPENTRY)
        (FNS \DORADOCOLOR.COLORLEVEL \DORADOCOLOR.SETONECOLOR)
        (FILES COLOR)
        (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\DORADOCOLOR.INIT])
(* * DORADOCOLOR -- Dorado machine dependent color display fns -- By Richard Burton, Herb Jellinek, 
and Kelly Roach.)

(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE

(BLOCKRECORD MonitorCB ((Seal WORD)
                            (Flags WORD)
                            (ACB WORD)
                            (NIL WORD)
                            (colorCB WORD)))

(BLOCKRECORD ChannelCB ((NIL WORD)
                            (wordsPerLine WORD)
                            (bitmapLo WORD)
                            (bitmapHi WORD)
                            (linesPerField WORD)
                            (pixelsPerLine WORD)
                            (leftMargin WORD)
                            (scan WORD)))

(BLOCKRECORD ColorCB ((ATableLo WORD)
                          (ATableHi WORD)
                          (NIL 6 WORD)
                          (VBtoVS BYTE)
                          (VStoVS BYTE)
                          (VStoVB WORD)
                          (VisibleLines WORD)
                          (X WORD)
                          (W BYTE)
                          (A BYTE)
                          (BtoA WORD)
                          (clockm BITS 12)
                          (clockd BITS 4)
                          (NIL WORD)))

(BLOCKRECORD ColorEntry ((NIL BITS 4)
                             (RedLo BITS 4)
                             (Blue BYTE)
                             (NIL BITS 4)
                             (Green BITS 8)
                             (RedHi BITS 4)))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ DORADO\COLORSCREENWIDTH 640)

(RPAQQ DORADO\COLORSCREENHEIGHT 480)

(RPAQQ DORADOCOLORPAGES 602)

(RPAQQ pplOffset 255)

(RPAQQ MCBPtr 268)

(RPAQQ MCBSeal 65326)

(RPAQQ MCBLow 160)

(RPAQQ MCBSize 8)

(RPAQQ AFlagsMask 4)

(RPAQQ ChCBLow 168)

(RPAQQ ChCBSize 8)

(RPAQQ ColCBLow 176)

(RPAQQ ColCBSize 16)

(RPAQQ CMapPages 8)


(CONSTANTS (DORADO\COLORSCREENWIDTH 640)
       (DORADO\COLORSCREENHEIGHT 480)
       (DORADOCOLORPAGES 602)
       (pplOffset 255)
       (MCBPtr 268)
       (MCBSeal 65326)
       (MCBLow 160)
       (MCBSize 8)
       (AFlagsMask 4)
       (ChCBLow 168)
       (ChCBSize 8)
       (ColCBLow 176)
       (ColCBSize 16)
       (CMapPages 8))
)
)
(* * \DORADOCOLOR.LEFTMARGIN should be set to 80 for small CONRACs, 56 for large CONRACs, and 40 for
 most other monitors. *)


(RPAQ? \DORADOCOLOR.LEFTMARGIN 80)

(RPAQ? \DORADOCOLOR.ATABLEIMAGE NIL)

(RPAQ? DORADOCOLOR.BITSPERPIXEL 8)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \DORADOCOLOR.ATABLEIMAGE \DORADOCOLOR.LEFTMARGIN DORADOCOLOR.BITSPERPIXEL)
)
(DEFINEQ

(\RGB.TO.DORADO.RGB
  [LAMBDA (RGB ColorEntryBox)                            (* kbr%: " 5-Jul-85 15:08")
    (PROG (ColorEntry)
          (SETQ ColorEntry (OR ColorEntryBox (\ALLOCBLOCK 1)))
          (replace (ColorEntry Blue) of ColorEntry with (fetch (RGB BLUE)
                                                                       of RGB))
          (replace (ColorEntry Green) of ColorEntry with (fetch (RGB GREEN)
                                                                        of RGB))
          (replace (ColorEntry RedLo) of ColorEntry with (LOGAND (fetch (RGB RED)
                                                                                of RGB)
                                                                            15))
          (replace (ColorEntry RedHi) of ColorEntry with (LRSH (fetch (RGB RED)
                                                                              of RGB)
                                                                           4))
          (RETURN ColorEntry])

(\DORADOCOLOR.LOOKATA
  [LAMBDA (MCB)                                          (* kbr%: " 5-Jul-85 16:04")
    (replace (MonitorCB Flags) of MCB with (LOGOR AFlagsMask (fetch (MonitorCB Flags)
                                                                            of MCB)))
    (while (EQ AFlagsMask (LOGAND AFlagsMask (fetch (MonitorCB Flags) of MCB)))
       do                                                (* wait for microcode to notice)
             (BLOCK])
)
(DEFINEQ

(\DORADOCOLOR.INIT
  [LAMBDA NIL                                            (* kbr%: "15-Feb-86 13:01")
    (DECLARE (GLOBALVARS \DORADOCOLORWSOPS \DORADOCOLORINFO))
    (SETQ \DORADOCOLORWSOPS (create WSOPS
                                   STARTBOARD _ (FUNCTION NILL)
                                   STARTCOLOR _ (FUNCTION \DORADOCOLOR.STARTCOLOR)
                                   STOPCOLOR _ (FUNCTION \DORADOCOLOR.STOPCOLOR)
                                   EVENTFN _ (FUNCTION \DORADOCOLOR.EVENTFN)
                                   SENDCOLORMAPENTRY _ (FUNCTION \DORADOCOLOR.SENDCOLORMAPENTRY)
                                   SENDPAGE _ (FUNCTION NILL)
                                   PILOTBITBLT _ (FUNCTION \DISPLAY.PILOTBITBLT)))
    (SETQ \DORADOCOLORINFO (create DISPLAYINFO
                                  DITYPE _ 'DORADOCOLOR
                                  DIWIDTH _ DORADO\COLORSCREENWIDTH
                                  DIHEIGHT _ DORADO\COLORSCREENHEIGHT
                                  DIBITSPERPIXEL _ 8
                                  DIWSOPS _ \DORADOCOLORWSOPS))
    (\DEFINEDISPLAYINFO \DORADOCOLORINFO])

(\DORADOCOLOR.STARTCOLOR
  [LAMBDA (FDEV)                                         (* kbr%: "21-Aug-85 15:55")
    (DECLARE (GLOBALVARS \DORADOCOLOR.LEFTMARGIN DORADOCOLOR.BITSPERPIXEL))
    (PROG (DISPLAYSTATE MCB AC CB)
          (COND
             ((EQ (MACHINETYPE)
                  'DORADO)
              (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV))
              (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'STARTCOLOR)
              (MOVD '\DISPLAY.PILOTBITBLT '\SOFTCURSORPILOTBITBLT)
              (\LOCKFN '\SOFTCURSORPILOTBITBLT)
              (SETQ MCB (EMADDRESS MCBLow))
              (SETQ AC (EMADDRESS ChCBLow))
              (SETQ CB (EMADDRESS ColCBLow))
              (\ZEROWORDS MCB (\ADDBASE MCB MCBSize))
              (\ZEROWORDS AC (\ADDBASE AC ChCBSize))
              (\ZEROWORDS CB (\ADDBASE CB ColCBSize))        (* Set up color control block)
              (OR \DORADOCOLOR.ATABLEIMAGE (SETQ \DORADOCOLOR.ATABLEIMAGE (\ALLOCBLOCK (ITIMES 
                                                                                            CMapPages
                                                                                              128)
                                                                                 NIL 128)))
              (\TEMPLOCKPAGES \DORADOCOLOR.ATABLEIMAGE CMapPages)
              (replace (ColorCB ATableHi) of CB with (\HILOC \DORADOCOLOR.ATABLEIMAGE))
                                                             (* Reverse pointer)
              (replace (ColorCB ATableLo) of CB with (\LOLOC \DORADOCOLOR.ATABLEIMAGE))
              (replace (ColorCB VBtoVS) of CB with 3)
              (replace (ColorCB VStoVS) of CB with 3)
              (replace (ColorCB VStoVB) of CB with 16)
              (replace (ColorCB VisibleLines) of CB with 240)
              (replace (ColorCB X) of CB with 379)
              (replace (ColorCB W) of CB with 6)
              (replace (ColorCB A) of CB with 35)
              (replace (ColorCB BtoA) of CB with 18)
              (replace (ColorCB clockm) of CB with 88)
              (replace (ColorCB clockd) of CB with 12)
                                                             (* set up channel control block)
              (replace (ChannelCB wordsPerLine) of AC with (FOLDHI (ITIMES 
                                                                              DORADO\COLORSCREENWIDTH
                                                                                      
                                                                             DORADOCOLOR.BITSPERPIXEL
                                                                                      )
                                                                              BITSPERWORD))
              (SETQ ColorScreenBitMapBase (fetch (BITMAP BITMAPBASE) of ColorScreenBitMap))
              (\TEMPLOCKPAGES ColorScreenBitMapBase DORADOCOLORPAGES)
              (replace (ChannelCB bitmapHi) of AC with (\HILOC ColorScreenBitMapBase))
              (replace (ChannelCB bitmapLo) of AC with (\LOLOC ColorScreenBitMapBase))
              (replace (ChannelCB linesPerField) of AC with (IQUOTIENT 
                                                                             DORADO\COLORSCREENHEIGHT
                                                                               2))
              (replace (ChannelCB pixelsPerLine) of AC with (IPLUS 
                                                                              DORADO\COLORSCREENWIDTH
                                                                               pplOffset))
              (replace (ChannelCB leftMargin) of AC with \DORADOCOLOR.LEFTMARGIN)
              (replace (ChannelCB scan) of AC with (SELECTQ DORADOCOLOR.BITSPERPIXEL
                                                                   (4 
                                                             (* Magic constants = |164B|)
                                                                      116)
                                                                   (8 
                                                             (* Magic constants = |170B|)
                                                                      120)
                                                                   (\ILLEGAL.ARG 
                                                                          DORADOCOLOR.BITSPERPIXEL)))
              (replace (MonitorCB Seal) of MCB with MCBSeal)
              (replace (MonitorCB Flags) of MCB with 60)
              (replace (MonitorCB ACB) of MCB with ChCBLow)
                                                             (* Wyatt used an empty A bitmap to 
                                                           establish scan mode.
                                                           Why? We dont)
              (replace (MonitorCB colorCB) of MCB with ColCBLow)
              (EMPUTBASE MCBPtr MCBLow)
              (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'ON])

(\DORADOCOLOR.STOPCOLOR
  [LAMBDA (FDEV)                                         (* kbr%: "21-Aug-85 15:56")
    (PROG (DISPLAYSTATE MCB)
          (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV))
          (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'STOPCOLOR)
          (SETQ MCB (EMADDRESS MCBLow))
          (replace (MonitorCB ACB) of MCB with 0)
          (\ZEROWORDS \DORADOCOLOR.ATABLEIMAGE (\ADDBASE \DORADOCOLOR.ATABLEIMAGE 32))
                                                             (* Black)
          (\DORADOCOLOR.LOOKATA MCB)
          (EMPUTBASE MCBPtr 0)
          (\TEMPUNLOCKPAGES \DORADOCOLOR.ATABLEIMAGE CMapPages)
          (\TEMPUNLOCKPAGES (fetch (BITMAP BITMAPBASE) of ColorScreenBitMap)
                 DORADOCOLORPAGES)
          (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'OFF])

(\DORADOCOLOR.EVENTFN
  [LAMBDA (FDEV EVENT)                                   (* kbr%: "24-Aug-85 16:55")
    (COND
       ((EQ (fetch (DISPLAYSTATE ONOFF) of (fetch (FDEV DEVICEINFO) of FDEV))
            'ON)
        (SELECTQ EVENT
            ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS)       (* turn off display since we may 
                                                           awake on different machine)
                 (COLORDISPLAY 'OFF))
            (AFTERSAVEVM                                     (* Rekick the color microcode.
                                                           *)
                         (\DORADOCOLOR.STARTCOLOR \COLORDISPLAYFDEV)
                         (SCREENCOLORMAP (SCREENCOLORMAP)))
            NIL])

(\DORADOCOLOR.SENDCOLORMAPENTRY
  [LAMBDA (FDEV COLOR# RGB)                              (* kbr%: " 5-Jul-85 15:06")
    (PROG (ScratchColorEntry J)
          (SETQ ScratchColorEntry (\RGB.TO.DORADO.RGB (LIST 0 0 0)))
          (OR \DORADOCOLOR.ATABLEIMAGE (SHOULDNT))
          (SETQ J (ITIMES COLOR# 8))
          (\RGB.TO.DORADO.RGB RGB ScratchColorEntry)
          (\PUTBASE \DORADOCOLOR.ATABLEIMAGE J (\GETBASE ScratchColorEntry 0))
          (\PUTBASE \DORADOCOLOR.ATABLEIMAGE (ADD1 J)
                 (\GETBASE ScratchColorEntry 1))
          (\DORADOCOLOR.LOOKATA (EMADDRESS MCBLow])
)
(DEFINEQ

(\DORADOCOLOR.COLORLEVEL
  [LAMBDA (DISPLAY COLOR# PRIMARYCOLOR NEWLEVEL)         (* kbr%: " 5-Jul-85 15:23")
    (PROG (REALCOLOR# COLORMAP ColorEntry)
          (SETQ REALCOLOR# (COLORNUMBERP COLOR#))
          (SETQ COLORMAP (SCREENCOLORMAP NIL DISPLAY))
          (SETQ ColorEntry (COLORMAPENTRY COLORMAP REALCOLOR#))
          (PROG1 (\GENERIC.COLORLEVEL COLORMAP REALCOLOR# PRIMARYCOLOR NEWLEVEL)
                                                             (* destructively modifies ColorEntry 
                                                           entry of COLORMAP to have correct 
                                                           level of PRIMARYCOLOR)
              (\DORADOCOLOR.SETONECOLOR ColorEntry REALCOLOR#))])

(\DORADOCOLOR.SETONECOLOR
  [LAMBDA (RGBTRIPLE COLOR#)                             (* kbr%: " 5-Jul-85 15:24")
    (PROG (DORADOFORMATCOLORCELL J)
          (OR \DORADOCOLOR.ATABLEIMAGE (SHOULDNT))
          (SETQ DORADOFORMATCOLORCELL (\RGB.TO.DORADO.RGB RGBTRIPLE))
          (SETQ J (LLSH COLOR# (IDIFFERENCE 11 DORADOCOLOR.BITSPERPIXEL)))
          (\PUTBASE \DORADOCOLOR.ATABLEIMAGE J (\GETBASE DORADOFORMATCOLORCELL 0))
          (\PUTBASE \DORADOCOLOR.ATABLEIMAGE (ADD1 J)
                 (\GETBASE DORADOFORMATCOLORCELL 1))
          (\DORADOCOLOR.LOOKATA (EMADDRESS MCBLow])
)

(FILESLOAD COLOR)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\DORADOCOLOR.INIT)
)
(PUTPROPS DORADOCOLOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1900 1986 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4684 6340 (\RGB.TO.DORADO.RGB 4694 . 5814) (\DORADOCOLOR.LOOKATA 5816 . 6338)) (6341 
15289 (\DORADOCOLOR.INIT 6351 . 7530) (\DORADOCOLOR.STARTCOLOR 7532 . 12956) (\DORADOCOLOR.STOPCOLOR 
12958 . 13864) (\DORADOCOLOR.EVENTFN 13866 . 14669) (\DORADOCOLOR.SENDCOLORMAPENTRY 14671 . 15287)) (
15290 16679 (\DORADOCOLOR.COLORLEVEL 15300 . 16071) (\DORADOCOLOR.SETONECOLOR 16073 . 16677)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/DORADOCOLOR.TEDIT b/internal/library/OBSOLETE/DORADOCOLOR.TEDIT
new file mode 100644
index 00000000..f7886f34
Binary files /dev/null and b/internal/library/OBSOLETE/DORADOCOLOR.TEDIT differ
diff --git a/internal/library/OBSOLETE/DSKTEST b/internal/library/OBSOLETE/DSKTEST
new file mode 100644
index 00000000..43859298
--- /dev/null
+++ b/internal/library/OBSOLETE/DSKTEST
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "15-Jun-90 14:09:54" {DSK}<usr>local>lde>lispcore>internal>library>DSKTEST.;2 62325  

      changes to%:  (VARS DSKTESTCOMS)
                    (FNS TESTEOFOP)

      previous date%: " 7-Dec-88 11:51:36" {DSK}<usr>local>lde>lispcore>internal>library>DSKTEST.;1
)


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

(PRETTYCOMPRINT DSKTESTCOMS)

(RPAQQ DSKTESTCOMS
       (
        (* ;; "This program is a file system tester.  It is suitable for testing any random-access filing device.  It is NOT intended for customer release.  DSKTEST is the entry function.")

        (FNS DSKTEST DELETETESTFILES)
        (FNS CHECKCONSISTENCY CHECKLENGTHANDCONTENTS CHOOSERANDOMFILEOPERATION DEFAULT.DSKFREEPAGESFN
             DEFAULT.DSKMINALLOCFN DEFAULT.DSKPAGESOVERHEADFN DOTESTFILEOP DSKFREEPAGES DSKMINALLOC 
             DSKPAGESOVERHEAD EXTENDTESTFILE FILEINFOFROMFILE GENERATEADDFILEOP GENERATECHANGEFILEOP
             GENERATEDELETEFILEOP GENERATEEOFPFILEOP GENERATEPEEKBINFILEOP GENERATEDELETEALLFILEOP 
             RANDOMELT RANDOMFILELENGTH RANDOMFILENAME RANDOMSTR RANDOMTESTFILE SORTBYCAR TESTFILEP 
             TESTEOFP TESTEOFOP TESTFILEPTR TESTPEEKBIN TRUNCATETESTFILE WORDIN WORDOUT DOUBLEWORDIN
             DOUBLEWORDOUT WRITETESTFILE WRITETESTFILELENGTH)
        (VARS (DSKFREEPAGESFN (FUNCTION DEFAULT.DSKFREEPAGESFN))
              (DSKPAGESOVERHEADFN (FUNCTION DEFAULT.DSKPAGESOVERHEADFN))
              (DSKMINALLOCFN (FUNCTION DEFAULT.DSKMINALLOCFN)))
        [VARS (MINTESTFILELENGTH 10)
              (FIRSTTESTWORD 48094)
              (SECONDTESTWORD 56187)
              (NUMBEROFTESTBYTES 5)
              (EXHAUSTIVETESTFLG)
              (DEFAULTREPLAYFILE '{PHYLUM}<LISPCORE>DLIONFS>REPLAY.LOG)
              (DONTCLOSEFILESFLG)
              (LEGALFILENAMECHARS '(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 0 1 2 3 4 5 6 7 8 9))
              (LEGALFIRSTFILENAMECHARS '(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]
        (VARS (MINFILENAMELENGTH 1)
              (MAXFILENAMELENGTH 15)
              (MINFILEEXTENSIONLENGTH 0)
              (MAXFILEEXTENSIONLENGTH 6)
              (MAXVERSION 64000)
              TESTFILEPAGELENGTHS)
        (GLOBALVARS FIRSTTESTWORD SECONDTESTWORD MINTESTFILELENGTH NUMBEROFTESTBYTES 
               EXHAUSTIVETESTFLG DSKFREEPAGESFN DSKPAGESOVERHEADFN TESTFILEPAGELENGTHS)
        (RECORDS TESTFILEINFO TESTFILEOP)))



(* ;; 
"This program is a file system tester.  It is suitable for testing any random-access filing device.  It is NOT intended for customer release.  DSKTEST is the entry function."
)

(DEFINEQ

(DSKTEST
  [LAMBDA (HOST/DIR KEEPREPLAYFILEFLG NUMOPERATIONS CURRENTFILES? DSKTESTBACKUP LOGFILE REPLAYFILE)
                                                             (* ; "Edited  6-Dec-88 19:31 by jds")
                                                             (* ; 
                                                        "note: SOME OF THIS MAY NOT BE IMPLEMENTED")

    (* ;; "this is a tester for file systems.  Basically it adds, deletes, extends and truncates files of various names and versions checking the consistency of the file system after each operation.  A log is kept of the operations so that it can be replayed to duplicate problems that may arise.")

    (* ;; "the two variables DSKFREEPAGESFN and DSKPAGESOVERHEADFN should be set to functions that return the number of free pages available and the overhead for a file with a given number of pages.")

    (* ;; "CURRENTFILES?  controls what the tester does with current files.  NIL means that their existance will be checked each time but not their contents.  T means that the files will be copied into directory DSKTESTBACKUP {defaults is CORE} and their contents will be checked.  DELETE will delete all of the test files before the test starts but will leave non test files on the directory.  Files written by DSKTEST have a two word key plus length which marks them as DSKTEST files.  The rest of them is all the same byte.")

    (* ;; "EXHAUSTIVEFLG if non-NIL indicates that every pass through, the entire contents of each file is checked.  Otherwise NUMBEROFTESTBYTES random bytes are examined each time.")

    (* ;; "LOGFILE is where print of progress is put {default to T}.  If KEEPREPLAYFILEFLG is T, REPLAYFILE is where the log of event suitable for replaying is kept {default is DEFAULTREPLAYFILE }.  If KEEPREPLAYFILEFLG is a file name, events are taken from that file until the last one.  Before the last event, BREAK1 is called.")

    (* ;; "DONTCLOSEFILESFLG if non-NIL indicates that files should be left open.  This should be faster as it avoids opening and closing files.")
                                                             (* ; 
                       "TESTFILEPAGELENGTHS is a list of page lengths that the files will be near.")
    (COND
       ((NOT (DIRECTORYNAME HOST/DIR))
        (CL:ERROR "Can't connect to directory ~A." HOST/DIR)))
    (SETQ HOST/DIR (DIRECTORYNAME HOST/DIR))
    (RESETLST
        (PROG ((NUMBEROFOPERATIONSDONE 0)
               FILESINFO FILEOP X FROMREPLAYFILE STARTINGTIME)
              [COND
                 [LOGFILE (SETQ LOGFILE (OPENSTREAM LOGFILE 'OUTPUT]
                 (T (SETQ LOGFILE T)
                    (COND
                       ([SETQ X (WFROMDS (GETSTREAM T 'OUTPUT]
                                                             (* ; "stop page holding")
                        (RESETSAVE (WINDOWPROP X 'PAGEFULLFN (FUNCTION NILL))
                               (LIST 'WINDOWPROP X 'PAGEFULLFN NIL]
              (COND
                 ((EQ KEEPREPLAYFILEFLG T)
                  (COND
                     [REPLAYFILE (SETQ REPLAYFILE (OPENSTREAM REPLAYFILE 'OUTPUT]
                     (T (SETQ REPLAYFILE DEFAULTREPLAYFILE)))(* ; 
                                                     "create a replay file and save its full name.")
                  (SETQ REPLAYFILE (OPENSTREAM REPLAYFILE 'OUTPUT))
                  (CLOSEF REPLAYFILE))
                 (KEEPREPLAYFILEFLG                          (* ; "use replay file")
                        (COND
                           ((SETQ FROMREPLAYFILE (OPENSTREAM KEEPREPLAYFILEFLG 'INPUT))
                            (SETFILEPTR FROMREPLAYFILE 0))
                           (T (ERROR KEEPREPLAYFILEFLG "replay file not found")))
                                                             (* ; 
                                                  "set so that no replay will be made of this run.")
                        (SETQ KEEPREPLAYFILEFLG)))           (* ; 
                                                           "connect to the tested directory.")
                                                             (* ; 
                              "RESETSAVE (CNDIR HOST/DIR) (LIST (QUOTE CNDIR) (DIRECTORYNAME T T))")
              (COND
                 ((EQ CURRENTFILES? 'DELETE)
                  (printout LOGFILE "Deleting any test files ...." T)
                  (DELETETESTFILES HOST/DIR)
                  (printout LOGFILE T)))
              [COND
                 [(AND CURRENTFILES? (NEQ CURRENTFILES? 'DELETE))
                                                             (* ; 
                                                           "check their contents after every sweep")
                  (printout T "Not implemented to check old file contents yet.")

                  (* ;; "this should copy each file into the backup directory and set the copy as the contents of the file information for the non-test files.")

                  (SETQ FILESINFO (for FILE in (SORT (DIRECTORY HOST/DIR))
                                     collect (FILEINFOFROMFILE FILE]
                 (T (SETQ FILESINFO (for FILE in (SORT (DIRECTORY HOST/DIR))
                                       collect (FILEINFOFROMFILE FILE]
              (SETQ STARTINGTIME (DATE))
              (printout LOGFILE "Beginning initial check at " STARTINGTIME " ......")
              (CHECKCONSISTENCY FILESINFO HOST/DIR)
              (BLOCK)
              (printout LOGFILE "  done." T)
          LP  (SETQ NUMBEROFOPERATIONSDONE (ADD1 NUMBEROFOPERATIONSDONE))
              [COND
                 ((AND (NUMBERP NUMOPERATIONS)
                       (GREATERP NUMBEROFOPERATIONSDONE NUMOPERATIONS))
                  (RETURN (LIST (SUB1 NUMBEROFOPERATIONSDONE)
                                'operations% done.]          (* ; "choose a new file operation")
              [COND
                 [FROMREPLAYFILE                             (* ; 
                                                           "getting events from the replay file")
                        (SETQ FILEOP (READ FROMREPLAYFILE))
                        (SKIPSEPRS FROMREPLAYFILE)
                        (COND
                           ((EOFP FROMREPLAYFILE)
                            (CLOSEF FROMREPLAYFILE)
                            (SETQ FROMREPLAYFILE)
                            (BREAK1 T T "Before last event on replay file"]
                 (T (SETQ FILEOP (CHOOSERANDOMFILEOPERATION FILESINFO HOST/DIR]
              [COND
                 (KEEPREPLAYFILEFLG                          (* ; 
                                                "put op on REPLAYFILE and make sure it gets there.")
                        (PROG [(STRM (OPENSTREAM REPLAYFILE 'APPEND]
                              (PRINT FILEOP STRM)
                              (CLOSEF STRM]
              (printout LOGFILE ".......... start=" STARTINGTIME "   time=" (DATE)
                     T)
              (PRINT FILEOP LOGFILE)
              (SETQ FILESINFO (DOTESTFILEOP FILEOP FILESINFO HOST/DIR LOGFILE))
              (printout LOGFILE "Consistency check after operation " NUMBEROFOPERATIONSDONE " .....")
              (BLOCK)
              [COND
                 ((NOT DONTCLOSEFILESFLG)

                  (* ;; "All files dshould be closed at this point:")

                  (for FILE in FILESINFO when (for OPENFILE in (OPENP)
                                                             thereis (EQ (FULLNAME OPENFILE)
                                                                             (fetch (TESTFILEINFO
                                                                                         
                                                                                     TESTFILEFULLNAME
                                                                                         )
                                                                                of FILE)))
                     do (HELP "File open that shouldn't be:" (fetch (TESTFILEINFO 
                                                                                   TESTFILEFULLNAME)
                                                                    of FILE]
              (CHECKCONSISTENCY FILESINFO HOST/DIR)
              (printout LOGFILE "  done." T)
              (GO LP)))])

(DELETETESTFILES
  [LAMBDA (HOST/DIR CHECKENTIRECONTENTSFLG)                  (* hts%: "22-Oct-84 16:27")
                                                             (* deletes any TEST files from 
                                                             directory HOST/DIR)
    (for FILE in (DIRECTORY HOST/DIR) when (TESTFILEP FILE (NOT CHECKENTIRECONTENTSFLG))
       do (if (OPENP FILE)
              then (CLOSEF FILE))
          (PRINT (DELFILE FILE)
                 T])
)
(DEFINEQ

(CHECKCONSISTENCY
  [LAMBDA (FILESINFO HOST/DIR)                               (* ; "Edited  2-Nov-87 13:55 by jds")
          
          (* ;; "checks that the state of the currently connected directory (or HOST/DIR, if given) is exactly the same as FILESINFO.")

    (PROG [(DIRFILES (SORT (DIRECTORY HOST/DIR]
          (for DIRFILE in DIRFILES as FILEINFO in FILESINFO
             do (BLOCK)
                [COND
                   ((NEQ (U-CASE DIRFILE)
                         (U-CASE (fetch (TESTFILEINFO TESTFILEFULLNAME) of FILEINFO)))
                                                             (* ; 
                                              "something is wrong with the directory.  Find out what")

                    (COND
                       ((FASSOC (U-CASE DIRFILE)
                               (MEMB FILEINFO FILESINFO))    (* ; "this file shows up later")

                        (ERROR "FILE MISSING .. " (fetch (TESTFILEINFO TESTFILEFULLNAME) of FILEINFO)
                               ))
                       (T (ERROR "NEW FILE HAS APPEARED .. " DIRFILE]
                (CHECKLENGTHANDCONTENTS FILEINFO])

(CHECKLENGTHANDCONTENTS
  [LAMBDA (FILEINFO)                                         (* ; "Edited  4-Nov-87 11:24 by jds")
          
          (* ;; "checks the length and contents of a file from its in core representation.")

    (PROG ((STRM (OPENSTREAM (fetch (TESTFILEINFO TESTFILEFULLNAME) of FILEINFO)
                        'INPUT))
           (FILELENGTH (fetch (TESTFILEINFO FILELENGTH) of FILEINFO))
           (STARTBYTE (fetch (TESTFILEINFO STARTBYTE) of FILEINFO))
           (PERIOD (fetch (TESTFILEINFO PERIOD) of FILEINFO)))
          (COND
             ([NOT (EQP FILELENGTH (GETFILEINFO STRM 'LENGTH]
              (ERROR "FILE has wrong length ... " FILEINFO)))
          [COND
             ((AND STARTBYTE PERIOD (IGEQ FILELENGTH MINTESTFILELENGTH))
          
          (* ;; "test files contain at least enough bytes to hold keys and stuff.  Maybe should have a special test for zero length files.")

              (COND
                 ((OR (NEQ (WORDIN STRM)
                           FIRSTTESTWORD)
                      (NEQ (WORDIN STRM)
                           SECONDTESTWORD)
                      (NOT (EQP FILELENGTH (DOUBLEWORDIN STRM)))
                      (NEQ (BIN STRM)
                           STARTBYTE)
                      (NEQ (BIN STRM)
                           PERIOD))
                  (ERROR "FIRST 10 bytes of file is wrong .. " FILEINFO)))
              [COND
                 ((IGREATERP FILELENGTH MINTESTFILELENGTH)   (* ; 
                                                         "only bother checking if we have data bytes")

                  (COND
                     ((EQ 1 (RAND 1 7))
          
          (* ;; "SCAN ENTIRE FILE once in about every seven tests.")

                      (bind READBYTE (CURVALUE _ STARTBYTE)
                            (BLOCKCOUNT _ 0) for COMPUTEDBYTE from STARTBYTE
                         to (IPLUS STARTBYTE FILELENGTH (IMINUS MINTESTFILELENGTH)
                                   -1) by 1 when [PROGN (COND
                                                           ((ZEROP (SETQ BLOCKCOUNT
                                                                    (IMOD (ADD1 BLOCKCOUNT)
                                                                          100)))
                                                            (BLOCK)))
                                                        (PROG1 (NEQ (SETQ READBYTE (\BIN STRM))
                                                                    CURVALUE)
                                                               (SETQ CURVALUE (IMOD (ADD1 CURVALUE)
                                                                                    PERIOD]
                         do (printout LOGFILE "FILE HAS WRONG BYTE .. " T "should have "
                                   (IMOD COMPUTEDBYTE PERIOD)
                                   " but read " READBYTE " from file" T "at location "
                                   (SUB1 (GETFILEPTR STRM))
                                   T)
                            (ERROR "FILE HAS WRONG BYTE .. " FILEINFO)))
                     (T 

(* ;;; "SPOT CHECK FILE")

                        [bind SPOT COMPUTEDBYTE READBYTE to 7
                           do (BLOCK)
                              (SETQ SPOT (RAND MINTESTFILELENGTH (SUB1 FILELENGTH)))
                              (SETQ COMPUTEDBYTE (PLUS (MINUS MINTESTFILELENGTH)
                                                       SPOT STARTBYTE))
                              (SETFILEPTR STRM SPOT)
                              (COND
                                 ((NEQ (SETQ READBYTE (\BIN STRM))
                                       (IMOD COMPUTEDBYTE PERIOD))
                                  (printout LOGFILE "FILE HAS WRONG BYTE .. " T "should have "
                                         (IMOD COMPUTEDBYTE PERIOD)
                                         " but read " READBYTE " from file" T "at location "
                                         (SUB1 (GETFILEPTR STRM))
                                         T)
                                  (ERROR "FILE HAS WRONG BYTE .. " FILEINFO]
                        (SETFILEPTR STRM FILELENGTH]
              (OR (EOFP STRM)
                  (ERROR "FILE doesn't get EOFP ... " FILEINFO]
          (OR DONTCLOSEFILESFLG (CLOSEF STRM])

(CHOOSERANDOMFILEOPERATION
  [LAMBDA (FILESINFO HOST/DIR)                               (* ; "Edited  2-Nov-87 12:25 by jds")
          
          (* ;; "chooses a random file operation add delete setlength on a random file and return a TESTFILEOP record for it.")

    (COND
       [FILESINFO (PROG ((RANDNUM (RAND 1 300)))
                        (RETURN (COND
                                   ((ILEQ RANDNUM 75)        (* ; "add a file")

                                    (GENERATEADDFILEOP FILESINFO NIL HOST/DIR))
                                   ((ILEQ RANDNUM 125)       (* ; "Change the length of a file")

                                    (GENERATECHANGEFILEOP FILESINFO HOST/DIR))
                                   ((ILEQ RANDNUM 175)       (* ; "delete a file")

                                    (GENERATEDELETEFILEOP FILESINFO NIL HOST/DIR))
                                   ((ILEQ RANDNUM 225)       (* ; "do EOFP test")

                                    (GENERATEEOFPFILEOP FILESINFO HOST/DIR))
                                   ((ILEQ RANDNUM 295)       (* ; "do PEEKBIN test")

                                    (GENERATEPEEKBINFILEOP FILESINFO HOST/DIR))
                                   (T                        (* ; "delete all files once in a while")

                                      (GENERATEDELETEALLFILEOP]
       (T                                                    (* ; "add a file")

          (GENERATEADDFILEOP FILESINFO NIL HOST/DIR])

(DEFAULT.DSKFREEPAGESFN
  [LAMBDA (HOST/DIR)                                     (* mjs "17-Apr-86 14:59")
    (SELECTQ (FILENAMEFIELD HOST/DIR 'HOST)
        (DSK (SELECTQ (MACHINETYPE)
                 ((DORADO) 
                      (DISKFREEPAGES HOST))
                 ((DANDELION DOVE) 
                      (DISKFREEPAGES HOST/DIR))
                 (MAIKO 500)
                 (SHOULDNT)))
        (FLOPPY (FLOPPY.FREE.PAGES))
        (PCDISK                                              (* remember to strip trailing colon 
                                                           off of device name!!)
                (VPCDISK.FREEPAGES (SUBATOM (FILENAMEFIELD HOST/DIR 'DEVICE)
                                          1 -2)))
        MAX.SMALLP])

(DEFAULT.DSKMINALLOCFN
  [LAMBDA (HOST/DIR)                                     (* mjs "22-Jan-86 12:18")
                                                             (* Default minimum-allocation unit 
                                                           function)
    (SELECTQ (FILENAMEFIELD HOST/DIR 'HOST)
        (DSK (SELECTQ (MACHINETYPE)
                 ((DANDELION DOVE)                           (* DLIONFS allocates 25 at a crackj.)
                      25)
                 ((DOLPHIN DORADO) 
                      1)
                 (MAIKO 1)
                 (SHOULDNT)))
        (FLOPPY 1)
        1])

(DEFAULT.DSKPAGESOVERHEADFN
  [LAMBDA (HOST/DIR NEWFILELENGTH)                       (* mjs "22-Jan-86 12:18")
                                                             (* default overhead function)
    (SELECTQ (FILENAMEFIELD HOST/DIR 'HOST)
        (DSK (SELECTQ (MACHINETYPE)
                 ((DANDELION DOVE) 

         (* * 11 is 5 for worst-case btree split on file, 5 for split on directory, 1 
       for leaderpage; NEWFILELENGTH and \LFrunSize for maximum length file will 
       attain during allocation; and \LFrunSize for possible directory extension.)

                      (PLUS 11 NEWFILELENGTH \LFrunSize \LFrunSize))
                 ((DOLPHIN DORADO) 
                      (IPLUS NEWFILELENGTH 5))
                 (MAIKO (IPLUS NEWFILELENGTH 5))
                 (SHOULDNT)))
        (FLOPPY (IPLUS NEWFILELENGTH 5))
        (IPLUS NEWFILELENGTH 5])

(DOTESTFILEOP
  [LAMBDA (FILEOP FILEINFOLST HOST/DIR LOGFILE)          (* ; "Edited  7-Dec-88 06:03 by jds")

    (* ;; "performs a TESTFILEOPERATION and updates the incore idea about what the directory should now look like.  Returns the changed FILEINFOLST.")
                                                             (* ; 
                                                     "operation can be add, delete or changelength")
    (SELECTQ (fetch (TESTFILEOP TESTOPERATION) of FILEOP)
        (ADD [PROG ((FULLFILE (fetch (TESTFILEOP TESTOPFILENAME) of FILEOP))
                    (BYTELEN (fetch (TESTFILEOP TESTOPFILELENGTH) of FILEOP))
                    (STARTBYTE (fetch (TESTFILEOP STARTBYTE) of FILEOP))
                    (PERIOD (fetch (TESTFILEOP PERIOD) of FILEOP))
                    (OLDDISKFREEPAGES (DSKFREEPAGES HOST/DIR)))
                   (COND
                      ((SETQ FULLFILE (WRITETESTFILE FULLFILE BYTELEN STARTBYTE PERIOD))
                       (BLOCK))
                      (T (ERROR "file wasn't written. " FILEOP)))
                   (COND
                      ((EQ FULLFILE T)
                       (HELP)))
                   (RETURN (SORTBYCAR (CONS (create TESTFILEINFO
                                                       TESTFILEFULLNAME _ FULLFILE
                                                       FILELENGTH _ BYTELEN
                                                       STARTBYTE _ STARTBYTE
                                                       PERIOD _ PERIOD
                                                       TESTFILEORIGNAME _ (fetch (TESTFILEOP
                                                                                      TESTOPFILENAME)
                                                                             of FILEOP))
                                                FILEINFOLST])
        (DELETE (PROG ((DELFILEINFO (fetch (TESTFILEOP TESTOPFILENAME) of FILEOP)))
                      (COND
                         ((DELFILE (fetch (TESTFILEINFO TESTFILEFULLNAME) of DELFILEINFO))
                          (BLOCK))
                         (T (ERROR "file won't delete" DELFILEINFO)))
                      (RETURN (REMOVE DELFILEINFO FILEINFOLST))))
        (DELETEALL (for F in FILEINFOLST unless (PROGN (BLOCK)
                                                                   (DELFILE (fetch (TESTFILEINFO
                                                                                        
                                                                                     TESTFILEFULLNAME
                                                                                        )
                                                                               of F)))
                      do (ERROR "file won't delete" F))
                   NIL)
        (CHANGELENGTH (PROG ((TESTFILE (fetch (TESTFILEINFO TESTFILEFULLNAME)
                                          of (fetch (TESTFILEOP TESTOPFILENAME) of FILEOP
                                                        )))
                             (NEWLENGTH (fetch (TESTFILEOP TESTOPFILELENGTH) of FILEOP))
                             (OLDDISKFREEPAGES (DSKFREEPAGES HOST/DIR))
                             NOWLENGTH CHANGEFILEINFO XFILEINFO)
                            (COND
                               ((SETQ CHANGEFILEINFO (for FILEINFO in FILEINFOLST
                                                        thereis (EQ (fetch (TESTFILEINFO
                                                                                    TESTFILEFULLNAME)
                                                                           of FILEINFO)
                                                                        TESTFILE)))

                                (* ;; "look for the one on FILEINFOLST that has the same name as this one may have been read in from the replay file and not be EQ.")

                                NIL)
                               (T (ERROR "changing a file that is not on file information list." 
                                         CHANGEFILEINFO)
                                  (RETURN)))
                            (COND
                               ((IGREATERP NEWLENGTH (SETQ NOWLENGTH (fetch (TESTFILEINFO 
                                                                                       FILELENGTH)
                                                                        of CHANGEFILEINFO)))
                                                             (* ; "extend the file")
                                (EXTENDTESTFILE TESTFILE (fetch (TESTFILEINFO STARTBYTE)
                                                                of CHANGEFILEINFO)
                                       (fetch (TESTFILEINFO PERIOD) of CHANGEFILEINFO)
                                       NOWLENGTH NEWLENGTH)
                                (BLOCK))
                               (T                            (* ; "truncate the file.")
                                  (TRUNCATETESTFILE TESTFILE NEWLENGTH)))
                            (replace (TESTFILEINFO FILELENGTH) of CHANGEFILEINFO with
                                                                                         NEWLENGTH)
                            (RETURN FILEINFOLST)))
        (EOFP (PROG ((TESTFILE (fetch (TESTFILEINFO TESTFILEFULLNAME) of (fetch
                                                                                  (TESTFILEOP 
                                                                                       TESTOPFILENAME
                                                                                         )
                                                                                    of FILEOP)))
                     (NEWLENGTH (fetch (TESTFILEOP TESTOPFILELENGTH) of FILEOP))
                     (OLDDISKFREEPAGES (DSKFREEPAGES HOST/DIR))
                     NOWLENGTH CHANGEFILEINFO XFILEINFO)
                    (COND
                       ((SETQ CHANGEFILEINFO (for FILEINFO in FILEINFOLST
                                                thereis (EQ (fetch (TESTFILEINFO 
                                                                                  TESTFILEFULLNAME)
                                                                   of FILEINFO)
                                                                TESTFILE)))

                        (* ;; "look for the one on FILEINFOLST that has the same name as this one may have been read in from the replay file and not be EQ.")

                        NIL)
                       (T (ERROR "changing a file that is not on file information list." 
                                 CHANGEFILEINFO)
                          (RETURN)))
                    (TESTEOFP TESTFILE (fetch (TESTFILEINFO STARTBYTE) of CHANGEFILEINFO)
                           (fetch (TESTFILEINFO PERIOD) of CHANGEFILEINFO)
                           NEWLENGTH LOGFILE)
                    (replace (TESTFILEINFO FILELENGTH) of CHANGEFILEINFO with NEWLENGTH)
                    (RETURN FILEINFOLST)))
        (PEEKBIN (PROG ((TESTFILE (fetch (TESTFILEINFO TESTFILEFULLNAME)
                                     of (fetch (TESTFILEOP TESTOPFILENAME) of FILEOP)))
                        CHANGEFILEINFO)
                       (COND
                          ((SETQ CHANGEFILEINFO (for FILEINFO in FILEINFOLST
                                                   thereis (EQ (fetch (TESTFILEINFO 
                                                                                     TESTFILEFULLNAME
                                                                                     ) of 
                                                                                             FILEINFO
                                                                          )
                                                                   TESTFILE)))

                           (* ;; "look for the one on FILEINFOLST that has the same name as this one may have been read in from the replay file and not be EQ.")

                           NIL)
                          (T (ERROR "changing a file that is not on file information list." 
                                    CHANGEFILEINFO)
                             (RETURN)))
                       (TESTPEEKBIN TESTFILE NIL LOGFILE)
                       (RETURN FILEINFOLST)))
        (ERROR "unknown file operation" FILEOP])

(DSKFREEPAGES
  [LAMBDA (HOST/DIR)                                         (* hts%: "29-Apr-84 16:23")
          
          (* returns the number of free pages in the connected directory if it knows how.)

    (APPLY* DSKFREEPAGESFN HOST/DIR])

(DSKMINALLOC
  [LAMBDA (HOST/DIR)                                         (* mjs "22-Jan-86 12:18")
          
          (* Calls the device dependent function that gives the minimum %# of pages the 
          file system will allocate at a crack.)

    (APPLY* DSKMINALLOCFN HOST/DIR])

(DSKPAGESOVERHEAD
  [LAMBDA (HOST/DIR NEWFILELENGTH)                           (* mjs "22-Jan-86 12:18")
          
          (* calls the device dependent function that gives the overhead per file)

    (APPLY* DSKPAGESOVERHEADFN HOST/DIR NEWFILELENGTH])

(EXTENDTESTFILE
  [LAMBDA (FILENAME STARTBYTE PERIOD OLDLENGTH NEWLENGTH)(* ; "Edited  7-Dec-88 05:59 by jds")

    (* ;; "extends a file by writing CONTENTS byte to it until it has length LONGERLENGTH.")

    (COND
       ((OPENP FILENAME)                                     (* ; 
                                                           "file may be open already for read.")
        (CLOSEF FILENAME)))
    (PROG [(STRM (OPENSTREAM FILENAME 'BOTH]
          (COND
             ((NULL STRM)
              (ERROR "file that it supposed to exist won't open for extending." FILENAME)))
                                                             (* ; 
                                                      "update the length count stored in the file.")
          (WRITETESTFILELENGTH STRM NEWLENGTH)
          (SETFILEPTR STRM OLDLENGTH)
          [for BYTE from (IPLUS STARTBYTE OLDLENGTH (IMINUS MINTESTFILELENGTH))
             to (IPLUS STARTBYTE NEWLENGTH (IMINUS MINTESTFILELENGTH)
                           -1) do (BOUT STRM (IMOD BYTE PERIOD))
                                     (COND
                                        ((ZEROP (IMOD BYTE 100))
                                         (BLOCK]
          (OR DONTCLOSEFILESFLG (CLOSEF STRM])

(FILEINFOFROMFILE
  [LAMBDA (FILE)                                             (* hts%: "22-Oct-84 15:44")
                                                             (* returns a TESTFILEINFO record of 
                                                             information about FILE.)
          
          (* keep track of test files differently because contents can be represented as 
          a single byte.)

    (if (EQ FILE T)
        then (HELP "FILE IS T!!?"))
    (PROG ((CONTENTS (TESTFILEP FILE NIL T)))
          (RETURN (create TESTFILEINFO
                         TESTFILEFULLNAME _ FILE
                         FILELENGTH _ (GETFILEINFO FILE 'LENGTH)
                         STARTBYTE _ (CAR CONTENTS)
                         PERIOD _ (CDR CONTENTS])

(GENERATEADDFILEOP
  [LAMBDA (FILEINFOLST STOPIFCANTFLG HOST/DIR)               (* edited%: "13-Aug-85 11:28")
    (PROG ((LENGTH (RANDOMFILELENGTH HOST/DIR))
           (PERIOD (RAND 1 255)))
          (RETURN (COND
                     (LENGTH (create TESTFILEOP
                                    TESTOPERATION _ 'ADD
                                    TESTOPFILENAME _ (RANDOMFILENAME HOST/DIR)
                                    TESTOPFILELENGTH _ LENGTH
                                    STARTBYTE _ (RAND 0 PERIOD)
                                    PERIOD _ PERIOD))
                     (STOPIFCANTFLG (ERROR "probably out of disk space."))
                     (T (GENERATEDELETEFILEOP FILEINFOLST T HOST/DIR])

(GENERATECHANGEFILEOP
  [LAMBDA (FILEINFOLST HOST/DIR)                             (* hts%: "29-Apr-84 16:29")
    (PROG ((FILETOCHANGE (RANDOMTESTFILE FILEINFOLST))
           (LENGTH (RANDOMFILELENGTH HOST/DIR)))
          (RETURN (COND
                     ((NULL FILETOCHANGE)                    (* create a file instead)
                      (GENERATEADDFILEOP FILEINFOLST T HOST/DIR))
                     ((NULL LENGTH)                          (* if can't change the length, try 
                                                             deleting a file.)
                      (GENERATEDELETEFILEOP FILEINFOLST T HOST/DIR))
                     (T (create TESTFILEOP
                               TESTOPERATION _ 'CHANGELENGTH
                               TESTOPFILENAME _ FILETOCHANGE
                               TESTOPFILELENGTH _ LENGTH])

(GENERATEDELETEFILEOP
  [LAMBDA (FILEINFOLST STOPIFNONEFLG HOST/DIR)               (* hts%: "22-Oct-84 16:54")
                                                             (* generates a delete file operation.)
          
          (* if it can't, it generates an file operation to ADD unless STOPIFNONEFLG is T)

    (PROG ((FILETODEL (RANDOMTESTFILE FILEINFOLST)))
          (RETURN (COND
                     (FILETODEL (create TESTFILEOP
                                       TESTOPERATION _ 'DELETE
                                       TESTOPFILENAME _ FILETODEL))
                     (STOPIFNONEFLG (ERROR "No file to delete"))
                     (T (GENERATEADDFILEOP FILEINFOLST T HOST/DIR])

(GENERATEEOFPFILEOP
  [LAMBDA (FILEINFOLST HOST/DIR)                             (* AJB "31-Jul-86 15:46")
    (PROG ((FILETOCHANGE (RANDOMTESTFILE FILEINFOLST))
           (LENGTH (RANDOMFILELENGTH HOST/DIR)))
          (RETURN (COND
                     ((NULL FILETOCHANGE)                    (* create a file instead)
                      (GENERATEADDFILEOP FILEINFOLST T HOST/DIR))
                     ((NULL LENGTH)                          (* if can't change the length, try 
                                                             deleting a file.)
                      (GENERATEDELETEFILEOP FILEINFOLST T HOST/DIR))
                     (T (create TESTFILEOP
                               TESTOPERATION _ 'EOFP
                               TESTOPFILENAME _ FILETOCHANGE
                               TESTOPFILELENGTH _ LENGTH])

(GENERATEPEEKBINFILEOP
  [LAMBDA (FILEINFOLST HOST/DIR)                             (* AJB " 1-Aug-86 10:14")
    (PROG ((FILETOCHANGE (RANDOMTESTFILE FILEINFOLST)))
          (RETURN (COND
                     ((NULL FILETOCHANGE)                    (* create a file instead)
                      (GENERATEADDFILEOP FILEINFOLST T HOST/DIR))
                     ((NULL LENGTH)                          (* if can't change the length, try 
                                                             deleting a file.)
                      (GENERATEDELETEFILEOP FILEINFOLST T HOST/DIR))
                     (T (create TESTFILEOP
                               TESTOPERATION _ 'PEEKBIN
                               TESTOPFILENAME _ FILETOCHANGE])

(GENERATEDELETEALLFILEOP
  [LAMBDA NIL                                                (* hts%: " 5-Jun-84 08:58")
    (create TESTFILEOP
           TESTOPERATION _ 'DELETEALL])

(RANDOMELT
  [LAMBDA (LST)                                              (* rrb "27-Mar-84 09:59")
                                                             (* returns a random element of a list.)
    (CAR (NTH LST (RAND 1 (LENGTH LST])

(RANDOMFILELENGTH
  [LAMBDA (HOST/DIR)                                         (* ; "Edited  2-Nov-87 12:27 by jds")
          
          (* ;; "returns a random file length.  (In bytes) that's guaranteed to fit in the file system in its current state.")

    (PROG ((NPAGES (RANDOMELT TESTFILEPAGELENGTHS))
           (DSKPAGES (DSKFREEPAGES HOST/DIR))
           (MINALLOC (DSKMINALLOC HOST/DIR))
           FILEOVERHEAD)                                     (* ; 
                                         "checks that there are enough free pages to store the file.")

          [COND
             ((ILEQ DSKPAGES (IPLUS MINALLOC (DSKPAGESOVERHEAD HOST/DIR MINALLOC)))
          
          (* ;; "There is no room for this file under any conditions -- there aren't enough pages to allocate a minimum-sized file")

              (RETURN NIL))
             ((IGREATERP (IPLUS NPAGES (SETQ FILEOVERHEAD (DSKPAGESOVERHEAD HOST/DIR NPAGES)))
                     DSKPAGES)
          
          (* ;; "There is room for A file.  Now pick a file size that will fit.  FILEOVERHEAD should be a high estimate of the overhead for the file, since the new NPAGES will be lower than the prior number.")

              (SETQ NPAGES (IDIFFERENCE DSKPAGES FILEOVERHEAD]
                                                             (* ; 
                                          "weight to return a length around an even number of pages.")

          (RETURN (IMAX MINTESTFILELENGTH (IPLUS (ITIMES NPAGES BYTESPERPAGE)
                                                 (SELECTQ (RAND 0 3)
                                                     (0 0)
                                                     (1 1)
                                                     (2 -1)
                                                     (RAND -511 512])

(RANDOMFILENAME
  [LAMBDA (HOST/DIR)                                         (* mjs "18-Apr-86 08:27")
                                                             (* generates a random file name.)
    (U-CASE (PACK* HOST/DIR (COND
                               [(EQ 'PCDISK (FILENAMEFIELD HOST/DIR 'HOST))
                                (PACKFILENAME 'NAME (RANDOMSTR (RAND 1 6))
                                       'EXTENSION
                                       (RANDOMSTR (RAND 0 3]
                               (T (PACKFILENAME 'NAME (RANDOMSTR (RAND MINFILENAMELENGTH 
                                                                       MAXFILENAMELENGTH))
                                         'EXTENSION
                                         (RANDOMSTR (RAND MINFILEEXTENSIONLENGTH 
                                                          MAXFILEEXTENSIONLENGTH))
                                         'VERSION
                                         (SELECTQ (RAND 0 1)
                                             (0              (* give an explicit extension)
                                                (RAND 1 MAXVERSION))
                                             NIL])

(RANDOMSTR
  [LAMBDA (NCHARS)                                           (* rrb "27-Mar-84 09:38")
                                                             (* returns a random string NCHARS 
                                                             long.)
    (PACK (CONS [CAR (NTH LEGALFIRSTFILENAMECHARS (RAND 1 (LENGTH LEGALFIRSTFILENAMECHARS]
                (bind (%#LEGALFILENAMECHARS _ (LENGTH LEGALFILENAMECHARS)) for I from 1
                   to (SUB1 NCHARS) collect (CAR (NTH LEGALFILENAMECHARS (RAND 1 %#LEGALFILENAMECHARS
                                                                               ])

(RANDOMTESTFILE
  [LAMBDA (FILEINFOLST)                                      (* hts%: "22-Oct-84 16:10")
          
          (* chooses a random test file from FILEINFOLST.
          This avoids deleting not test files.)

    (PROG ((NTESTFILES (for FILE in FILEINFOLST when (SMALLP (fetch (TESTFILEINFO STARTBYTE)
                                                                of FILE)) sum 1))
           NFILE)
          (RETURN (if (NEQ NTESTFILES 0)
                      then (SETQ NFILE (RAND 1 NTESTFILES))
                           (for FILE in FILEINFOLST when (SMALLP (fetch (TESTFILEINFO STARTBYTE)
                                                                    of FILE))
                              do (if (ZEROP (SETQ NFILE (SUB1 NFILE)))
                                     then (RETURN FILE])

(SORTBYCAR
  [LAMBDA (LST)                                          (* ; "Edited  6-Dec-88 22:54 by jds")
                                                             (* sorts a list by its CARs)
    (SORT LST (FUNCTION (LAMBDA (A B)
                          (ALPHORDER (U-CASE (CAR A))
                                 (U-CASE (CAR B])

(TESTFILEP
  [LAMBDA (FILE HINTONLYFLG RETURNCONTENTSFLG)               (* ; "Edited  3-Nov-87 16:26 by jds")
          
          (* ;; "determines if a file is a test file.")

    (PROG ((STRM (OPENSTREAM FILE 'INPUT))
           FILELENGTH STARTBYTE PERIOD)
          (SETQ FILELENGTH (GETFILEINFO STRM 'LENGTH))
          (RETURN (PROG1 [COND
                            ((ILESSP FILELENGTH MINTESTFILELENGTH)
          
          (* ;; "test files contain at least enough bytes to hold keys and stuff.  Maybe should have a special test for zero length files.")

                             NIL)
                            ((AND (EQ (WORDIN STRM)
                                      FIRSTTESTWORD)
                                  (EQ (WORDIN STRM)
                                      SECONDTESTWORD)
                                  (EQP FILELENGTH (DOUBLEWORDIN STRM)))
                             (COND
                                (HINTONLYFLG                 (* ; 
                                                   "if asking about hint only, don't check contents.")

                                       (COND
                                          (RETURNCONTENTSFLG (CONS (BIN STRM)
                                                                   (BIN STRM)))
                                          (T FILE)))
                                (T (SETQ STARTBYTE (BIN STRM))
                                   (SETQ PERIOD (BIN STRM))
                                   (bind (RUNNINGVALUE _ STARTBYTE) for COMPUTEDBYTE from STARTBYTE
                                      to (IPLUS STARTBYTE FILELENGTH -1 (IMINUS MINTESTFILELENGTH))
                                      when (PROG1 (NEQ (BIN STRM)
                                                       RUNNINGVALUE)
                                                  (SETQ RUNNINGVALUE (IMOD (ADD1 RUNNINGVALUE)
                                                                           PERIOD)))
                                      do (RETURN NIL) finally (RETURN (COND
                                                                         (RETURNCONTENTSFLG
                                                                          (CONS STARTBYTE PERIOD))
                                                                         (T FILE]
                         (CLOSEF STRM])

(TESTEOFP
  [LAMBDA (FILENAME STARTBYTE PERIOD NEWLENGTH LOGFILE)  (* ; "Edited  7-Dec-88 06:04 by jds")

    (* ;; "Test the EOFP method for this file device.")

    (COND
       ((OPENP FILENAME)                                     (* ; 
                                                           "file may be open already for read.")
        (CLOSEF FILENAME)))
    (LET* [(STRM (OPENSTREAM FILENAME 'BOTH))
           (OLDLENGTH (GETFILEINFO STRM 'LENGTH]
          (COND
             ((NULL STRM)
              (CL:WARN "file ~A won't open for end of file tests." FILENAME)))
          [COND
             [(SETFILEINFO STRM 'LENGTH NEWLENGTH)
              (COND
                 ((NOT (= (\GETEOFPTR STRM)
                          NEWLENGTH))
                  (CL:FORMAT LOGFILE "Changing file ~A to NEWLENGTH ~D didn't change EOFPTR.
" FILENAME NEWLENGTH)
                  (CL:WARN "Changing file ~A to NEWLENGTH ~D didn't change EOFPTR.
" FILENAME NEWLENGTH)))
              (SETFILEPTR STRM NEWLENGTH)
              (WRITETESTFILELENGTH STRM NEWLENGTH)
              (CLOSEF STRM)
              [COND
                 ((NOT (EQP (GETFILEINFO FILENAME 'LENGTH)
                            NEWLENGTH))
                  (CL:FORMAT LOGFILE "Changing file ~A to NEWLENGTH ~D didn't take; length still ~D"
                         FILENAME NEWLENGTH (GETFILEINFO FILENAME 'LENGTH))
                  (CL:WARN "Changing file ~A to NEWLENGTH ~D didn't take; length still ~D" FILENAME 
                         NEWLENGTH (GETFILEINFO FILENAME 'LENGTH]
              (SETQ STRM (OPENSTREAM FILENAME 'BOTH))
              (COND
                 ((NOT (EQP (GETFILEINFO FILENAME 'LENGTH)
                            NEWLENGTH))
                  (CL:FORMAT LOGFILE 
                         "Re-opening file ~A after changing to NEWLENGTH ~D lost new length.
" FILENAME NEWLENGTH)
                  (CL:WARN "Re-opening file ~A after changing to NEWLENGTH ~D lost new length.
" FILENAME NEWLENGTH)))
              (TESTFILEPTR STRM NEWLENGTH LOGFILE)
              (SETFILEINFO STRM 'LENGTH NEWLENGTH)
              (CLOSEF STRM)
              (COND
                 ((NOT (EQP (GETFILEINFO FILENAME 'LENGTH)
                            NEWLENGTH))
                  (CL:WARN "Changing file ~A to NEWLENGTH ~D the second time didn't take either.
" FILENAME NEWLENGTH]
             (T (SETQ NEWLENGTH (GETFILEINFO STRM 'LENGTH]
          (SETQ STRM (OPENSTREAM FILENAME 'INPUT))
          [for I from 0 to (SUB1 NEWLENGTH) do (COND
                                                                  ((EOFP STRM)
                                                                   (ERROR "EARLY EOF" I)))
                                                              (BIN STRM)
             finally (COND
                            ((NOT (EOFP STRM))
                             (ERROR "EOFP not true at end of file"]
          (TESTEOFOP STRM NEWLENGTH (FUNCTION ZERO)
                 0 LOGFILE)
          (TESTEOFOP STRM NEWLENGTH (FUNCTION NILL)
                 NIL LOGFILE)
          (CLOSEF STRM)
          (EXTENDTESTFILE FILENAME STARTBYTE PERIOD OLDLENGTH NEWLENGTH])

(TESTEOFOP
  [LAMBDA (STREAM FILESIZE FN EOFVALUE LOGFILE)          (* ; "Edited 15-Jun-90 14:04 by jds")

    (* ;; 
  "Test ENDOFSTREAMOP, using FN as the function to call (THAT FUNCTION SHOULD RETURN EOFVALUE)")

    (PRINTOUT LOGFILE %,, %,, "Testing with ENDOFSTREAMOP set to " FN T)
    (SETFILEPTR STREAM 0)
    (replace (STREAM ENDOFSTREAMOP) of STREAM with FN)
    (for I from 0 to (SUB1 FILESIZE) do (COND
                                                           ((EOFP STREAM)
                                                            (ERROR "Early EOF at" I)))
                                                       (BIN STREAM)
       finally (COND
                      ((NOT (EOFP STREAM))
                       (ERROR "EOFP NIL at EOF.")))
             (OR (EQ EOFVALUE (BIN STREAM))
                 (ERROR "End-of-stream value not returned right from function " FN))
             (OR (EOFP STREAM)
                 (ERROR "EOFP is NIL after a BIN at EOF"])

(TESTFILEPTR
  [LAMBDA (STRM FILESIZE LOGFILE)                        (* ; "Edited  7-Dec-88 11:42 by jds")

(* ;;; "Test setting fileptr past EOF")

    (PRINTOUT LOGFILE .TAB 5 "Testing FILEPTR" T)
    (PRINTOUT LOGFILE .TAB 10 "FILESIZE = " FILESIZE T)
    (bind BYTE for FILEPTR in '(8192 512 4096 8191 513 4097 8193 511 4095)
       do (PRINTOUT LOGFILE .TAB 10 "Setting EOF and FILEPTR to " FILESIZE T)
             (SETFILEINFO STRM 'LENGTH FILESIZE)
             (SETFILEPTR STRM FILESIZE)
             (COND
                ((NOT (EOFP STRM))
                 (CL:WARN "EOFP not set at ~D " FILESIZE)))
             (PRINTOUT LOGFILE .TAB 10 "FILESIZE extended by " FILEPTR T)
             (SETFILEPTR STRM (IPLUS FILESIZE FILEPTR))
             [COND
                ((CL:/= (IPLUS FILESIZE FILEPTR)
                        (GETFILEPTR STRM))
                 (CL:WARN "FILEPOS wrong after SETFILEPTR; is ~D, should be ~D.
" (GETFILEPTR STRM)
                        (IPLUS FILESIZE FILEPTR]
             (BOUT STRM 6)
             [COND
                ((CL:/= (IPLUS FILESIZE FILEPTR 1)
                        (GETFILEPTR STRM))
                 (CL:WARN "FILEPOS wrong after BOUT; is ~D, should be ~D.
" (GETFILEPTR STRM)
                        (IPLUS FILESIZE FILEPTR 1]
             (SETFILEPTR STRM FILESIZE)
             (PRINTOUT LOGFILE .TAB 10 "Testing new allocated area = zero" T)
             [for I from FILESIZE to (IPLUS FILESIZE FILEPTR -1)
                do (COND
                          ((NEQ (BIN STRM)
                                0)
                           (CL:WARN "Newly-allocated area not zeroed.")
                           (RETURN]
             (PRINTOUT LOGFILE .TAB 10 "Testing new EOF and last byte written" T)
             (COND
                ((EOFP STRM)
                 (CL:WARN "Early EOF; before BINning file's last byte.
")))
             (COND
                ((NEQ (SETQ BYTE (BIN STRM))
                      6)
                 (CL:WARN "BIN didn't return what was just BOUTed; was ~D, should be 6.
" BYTE)))
             (COND
                ((EOFP STRM))
                (T (CL:WARN "EOFP false after BINning file's final byte.")))
       finally (SETFILEINFO STRM 'LENGTH FILESIZE)
             (SETFILEPTR STRM FILESIZE])

(TESTPEEKBIN
  [LAMBDA (FILE DONT.TRY.HARD.FLG LOGFILE)               (* ; "Edited  3-Nov-88 11:23 by jds")

    (* ;; "Test the various cases of PEEKBIN")

    (PROG ((STRM (OPENSTREAM FILE 'INPUT 'OLD))
           STRMLEN)
          (RESETLST
              (RESETSAVE NIL (LIST 'CLOSEF? STRM))
              (SETQ STRMLEN (GETEOFPTR STRM))
              [for PTR in (APPEND [LIST 0 STRMLEN (IMAX (SUB1 STRMLEN)
                                                                0)
                                                (ADD1 STRMLEN)
                                                (IPLUS (RAND 1 10)
                                                       (IMIN 16777200 (ITIMES (RAND 2 5)
                                                                             STRMLEN]
                                         (for X from -1 to STRMLEN by 512
                                            when (IGREATERP X 0) collect X)
                                         (for X from 0 to STRMLEN by 512 collect
                                                                                         X)
                                         (for X from 1 to STRMLEN by 512 collect
                                                                                         X)
                                         (for X from 1 to 5 collect (RAND 0 STRMLEN))
                                         ) bind C.PEEK.NIL C.PEEK.T C.BIN PTR2 PTR3
                 do (SETFILEPTR STRM PTR)
                       (SETQ C.PEEK.NIL (NLSETQ (\PEEKBIN STRM)))
                       (SETQ PTR2 (GETFILEPTR STRM))
                       [COND
                          ((NOT DONT.TRY.HARD.FLG)
                           (COND
                              ((NOT (EQUAL PTR PTR2))
                               (PRINTOUT LOGFILE "\PEEKBIN moving file ptr!" T]
                       (SETQ C.PEEK.T (NLSETQ (\PEEKBIN STRM T)))
                       (SETQ PTR3 (GETFILEPTR STRM))
                       [COND
                          ((NOT DONT.TRY.HARD.FLG)
                           (COND
                              ((NOT (EQUAL PTR PTR3))
                               (PRINTOUT LOGFILE "\PEEKBIN moving file ptr!" T]
                       (SETQ C.BIN (NLSETQ (BIN STRM)))
                       (COND
                          [(IGEQ PTR STRMLEN)                (* ; "at EOS")
                           [COND
                              ((NOT DONT.TRY.HARD.FLG)
                               (COND
                                  ((NOT (AND (EQUAL C.PEEK.NIL NIL)
                                             (EQUAL C.PEEK.T '(NIL))
                                             (EQUAL C.BIN NIL)))
                                   (PRINTOUT LOGFILE "\PEEKBIN or BIN not working correctly at EOS" T
                                          ]
                           (COND
                              ((NOT DONT.TRY.HARD.FLG)
                               (COND
                                  ((NOT (EQUAL (GETFILEPTR STRM)
                                               PTR))
                                   (PRINTOUT LOGFILE "BIN moving fileptr at eos" T]
                          (T                                 (* ; "before EOS")
                             (COND
                                ((NOT (AND (EQUAL C.PEEK.NIL C.PEEK.T)
                                           (EQUAL C.PEEK.T C.BIN)))
                                 (PRINTOUT LOGFILE "\PEEKBIN and BIN not returning same value!" T)))
                             (COND
                                ((NOT (EQUAL (GETFILEPTR STRM)
                                             (ADD1 PTR)))
                                 (PRINTOUT LOGFILE "BIN not moving ptr correctly!" T]
              (CLOSEF? STRM))])

(TRUNCATETESTFILE
  [LAMBDA (FILENAME NEWLENGTH)                           (* ; "Edited  3-Nov-87 13:43 by jds")
                                                             (* ; "truncates a test file")
    [COND
       ((OPENP FILENAME)                                     (* ; 
                                                           "file may be open already for read.")
        (CLOSEF (OPENP FILENAME]
    (PROG [(STRM (OPENSTREAM FILENAME 'BOTH]
          (COND
             ((NULL STRM)
              (ERROR "file that it supposed to exist won't open for truncation." FILENAME)))
          (WRITETESTFILELENGTH STRM NEWLENGTH)
          (SETFILEPTR STRM NEWLENGTH)
          (SETFILEINFO STRM 'LENGTH NEWLENGTH)
          (CLOSEF STRM)
          (COND
             ((CL:/= (GETFILEINFO FILENAME 'LENGTH)
                     NEWLENGTH)
              (CL:WARN "changing file ~A to NEWLENGTH ~D didn't take" FILENAME NEWLENGTH])

(WORDIN
  [LAMBDA (STRM)                                             (* rrb "27-Mar-84 14:37")
                                                             (* read two bytes from a stream)
    (LOGOR (LLSH (\BIN STRM)
                 8)
           (\BIN STRM])

(WORDOUT
  [LAMBDA (STRM WORD)                                        (* bouts two bytes onto stream)
    (\BOUT STRM (LRSH WORD 8))
    (\BOUT STRM (LOGAND WORD 255])

(DOUBLEWORDIN
  [LAMBDA (FILE)                                             (* jds " 3-JAN-83 16:08")
    (IPLUS (LLSH (\BIN FILE)
                 24)
           (LLSH (\BIN FILE)
                 16)
           (LLSH (\BIN FILE)
                 8)
           (\BIN FILE])

(DOUBLEWORDOUT
  [LAMBDA (FILE NUMBER)                                      (* jds " 3-JAN-83 15:30")
    (\BOUT FILE (LOGAND 255 (LRSH NUMBER 24)))
    (\BOUT FILE (LOGAND 255 (LRSH NUMBER 16)))
    (\BOUT FILE (LOGAND 255 (LRSH NUMBER 8)))
    (\BOUT FILE (LOGAND 255 NUMBER])

(WRITETESTFILE
  [LAMBDA (NAME LENGTH STARTBYTE PERIOD)                     (* ; "Edited  4-Nov-87 11:21 by jds")
          
          (* ;; "writes a test file of length LENGTH with contents CONTENTBYTE")

    (PROG [(STRM (OPENSTREAM NAME 'OUTPUT]
          (OR STRM (RETURN NIL))
          (COND
             ((ILESSP LENGTH MINTESTFILELENGTH)
              (ERROR "test files must have a minimum length " MINTESTFILELENGTH)))
          (WORDOUT STRM FIRSTTESTWORD)
          (WORDOUT STRM SECONDTESTWORD)
          (DOUBLEWORDOUT STRM LENGTH)
          (BOUT STRM STARTBYTE)
          (BOUT STRM PERIOD)
          [bind (CURRENTBYTE _ STARTBYTE)
                BLOCKCOUNT _ 0 for COMPUTEDBYTE from STARTBYTE to (IPLUS STARTBYTE LENGTH
                                                                         (IMINUS MINTESTFILELENGTH)
                                                                         -1)
             do (BOUT STRM CURRENTBYTE)
                (SETQ CURRENTBYTE (IMOD (ADD1 CURRENTBYTE)
                                        PERIOD))
                (COND
                   ((ZEROP (SETQ BLOCKCOUNT (IMOD (ADD1 BLOCKCOUNT)
                                                  100)))
                    (BLOCK]
          (CLOSEF STRM)
          (RETURN (FULLNAME STRM])

(WRITETESTFILELENGTH
  [LAMBDA (STRM NEWLENGTH)                               (* ; "Edited  3-Nov-88 10:45 by jds")
                                                             (* ; 
                                                      "update the length count stored in the file.")
    (SETFILEPTR STRM 4)
    (DOUBLEWORDOUT STRM NEWLENGTH])
)

(RPAQ DSKFREEPAGESFN (FUNCTION DEFAULT.DSKFREEPAGESFN))

(RPAQ DSKPAGESOVERHEADFN (FUNCTION DEFAULT.DSKPAGESOVERHEADFN))

(RPAQ DSKMINALLOCFN (FUNCTION DEFAULT.DSKMINALLOCFN))

(RPAQQ MINTESTFILELENGTH 10)

(RPAQQ FIRSTTESTWORD 48094)

(RPAQQ SECONDTESTWORD 56187)

(RPAQQ NUMBEROFTESTBYTES 5)

(RPAQQ EXHAUSTIVETESTFLG NIL)

(RPAQQ DEFAULTREPLAYFILE {PHYLUM}<LISPCORE>DLIONFS>REPLAY.LOG)

(RPAQQ DONTCLOSEFILESFLG NIL)

(RPAQQ LEGALFILENAMECHARS
       (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 0 1 2 3 4 5 6 7 8 9))

(RPAQQ LEGALFIRSTFILENAMECHARS
       (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))

(RPAQQ MINFILENAMELENGTH 1)

(RPAQQ MAXFILENAMELENGTH 15)

(RPAQQ MINFILEEXTENSIONLENGTH 0)

(RPAQQ MAXFILEEXTENSIONLENGTH 6)

(RPAQQ MAXVERSION 64000)

(RPAQQ TESTFILEPAGELENGTHS
       (1 2 3 5 7 8 11 13 16 17 19 21 23 24 29 31 34 37 41 43 47 64 55 78 89 128 129 255 256 257 333
          512 837 1024 1997 2048 3333 4096 5432 8192 11321 16384 19997 32768 43210 65535))
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS FIRSTTESTWORD SECONDTESTWORD MINTESTFILELENGTH NUMBEROFTESTBYTES EXHAUSTIVETESTFLG 
       DSKFREEPAGESFN DSKPAGESOVERHEADFN TESTFILEPAGELENGTHS)
)
(DECLARE%: EVAL@COMPILE

(RECORD TESTFILEINFO (TESTFILEFULLNAME FILELENGTH STARTBYTE PERIOD TESTFILEORIGNAME))

(RECORD TESTFILEOP (
                        (* ;; "Describes one DSKTEST file operation, for the log and for replay.")

                        TESTOPERATION                        (* ; 
                            "Operation to be performed.  One of: ADD DELETE CHANGELENGTH DELETEALL")
                        TESTOPFILENAME                       (* ; 
                                                           "File name of the file operated on")
                        TESTOPFILELENGTH                     (* ; "New length for the file")
                        STARTBYTE                            (* ; "%"Random%" data start < PERIOD")
                        PERIOD                               (* ; "%"Random%" data period < 256")
                        ))
)
(PUTPROPS DSKTEST COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2943 12078 (DSKTEST 2953 . 11544) (DELETETESTFILES 11546 . 12076)) (12079 59900 (
CHECKCONSISTENCY 12089 . 13302) (CHECKLENGTHANDCONTENTS 13304 . 17796) (CHOOSERANDOMFILEOPERATION 
17798 . 19365) (DEFAULT.DSKFREEPAGESFN 19367 . 20152) (DEFAULT.DSKMINALLOCFN 20154 . 20803) (
DEFAULT.DSKPAGESOVERHEADFN 20805 . 21709) (DOTESTFILEOP 21711 . 30611) (DSKFREEPAGES 30613 . 30872) (
DSKMINALLOC 30874 . 31180) (DSKPAGESOVERHEAD 31182 . 31453) (EXTENDTESTFILE 31455 . 32765) (
FILEINFOFROMFILE 32767 . 33586) (GENERATEADDFILEOP 33588 . 34342) (GENERATECHANGEFILEOP 34344 . 35248)
 (GENERATEDELETEFILEOP 35250 . 35987) (GENERATEEOFPFILEOP 35989 . 36881) (GENERATEPEEKBINFILEOP 36883
 . 37672) (GENERATEDELETEALLFILEOP 37674 . 37866) (RANDOMELT 37868 . 38122) (RANDOMFILELENGTH 38124 . 
40003) (RANDOMFILENAME 40005 . 41255) (RANDOMSTR 41257 . 41921) (RANDOMTESTFILE 41923 . 42826) (
SORTBYCAR 42828 . 43181) (TESTFILEP 43183 . 45623) (TESTEOFP 45625 . 48865) (TESTEOFOP 48867 . 49898) 
(TESTFILEPTR 49900 . 52243) (TESTPEEKBIN 52245 . 56179) (TRUNCATETESTFILE 56181 . 57146) (WORDIN 57148
 . 57425) (WORDOUT 57427 . 57602) (DOUBLEWORDIN 57604 . 57889) (DOUBLEWORDOUT 57891 . 58181) (
WRITETESTFILE 58183 . 59529) (WRITETESTFILELENGTH 59531 . 59898)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/DSKTEST.TEDIT b/internal/library/OBSOLETE/DSKTEST.TEDIT
new file mode 100644
index 00000000..33b0ae37
Binary files /dev/null and b/internal/library/OBSOLETE/DSKTEST.TEDIT differ
diff --git a/internal/library/OBSOLETE/FILEBANGER b/internal/library/OBSOLETE/FILEBANGER
new file mode 100644
index 00000000..b74f1164
--- /dev/null
+++ b/internal/library/OBSOLETE/FILEBANGER
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "14-Jun-90 21:20:39" {DSK}<usr>local>lde>lispcore>internal>library>FILEBANGER.;2 16050  

      changes to%:  (VARS FILEBANGERCOMS)
                    (FNS CHECKFORZEROS)

      previous date%: " 1-Oct-87 18:36:57" {DSK}<usr>local>lde>lispcore>internal>library>FILEBANGER.;1
)


(* ; "
Copyright (c) 1983, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT FILEBANGERCOMS)

(RPAQQ FILEBANGERCOMS
       ((FNS DOFILEBANGER DOMAKEFILEBANGER DOZEROBANGER FILEBANGER FBCOPYBYTES FBMAKETESTFILE 
             MAKEBANGERWINDOW MAKEFILEBANGER ZEROBANGER SUSPEND.FILEBANGER WATCHDISKPAGES)
        (FNS BINCOM)
        (FNS CHECKFORZEROS)
        (INITVARS (FBREPEATCOUNT 4)
               (FILEBANGERS))
        (PROP FILETYPE FILEBANGER)))
(DEFINEQ

(DOFILEBANGER
  [LAMBDA (DESTINATION LENGTH NOBREAK)                     (* ; "Edited  1-Oct-87 18:00 by Daniels")

    (push FILEBANGERS (ADD.PROCESS `(FILEBANGER ',LENGTH ',DESTINATION T ',NOBREAK])

(DOMAKEFILEBANGER
  [LAMBDA (SOURCE)                                           (* bvm%: "14-AUG-83 13:53")
    (push FILEBANGERS (ADD.PROCESS `(MAKEFILEBANGER (QUOTE %, SOURCE])

(DOZEROBANGER
  [LAMBDA (TESTFILE1 TESTFILE2 TMPFILENAME)                  (* bvm%: "14-AUG-83 13:54")
    (push FILEBANGERS (ADD.PROCESS `(ZEROBANGER (QUOTE %, TESTFILE1)
                                           (QUOTE %, TESTFILE2)
                                           (QUOTE %, TMPFILENAME])

(FILEBANGER
  [LAMBDA (TESTFILE DESTINATION MAKEWINDOW NOBREAK INPARMS OUTPARMS)
                                                           (* ; "Edited  1-Oct-87 18:31 by Daniels")

    (DECLARE (SPECVARS ERRCNT LOOPCNT))
    (RESETLST (PROG ((ERRCNT 0)
                     (LOOPCNT 0)
                     (OPTION (AND (NOT NOBREAK)
                                  'BREAK))
                     MYFILE NEWFILE LASTFILE TMPFILENAME OUTPUTSTREAM)
                    [COND
                       [(OR (NULL TESTFILE)
                            (FIXP TESTFILE))
                        (SETQ TESTFILE (SETQ MYFILE (FBMAKETESTFILE TESTFILE
                                                           (PACKFILENAME 'EXTENSION 'SOURCE
                                                                  'BODY
                                                                  (OR DESTINATION 'FILEBANGER]
                       (T (SETQ TESTFILE (CL:PROBE-FILE (OR TESTFILE (RETURN "No TESTFILE supplied"]
                    [COND
                       [MAKEWINDOW (SETQ OUTPUTSTREAM (GETSTREAM (MAKEBANGERWINDOW TESTFILE 
                                                                        "File Banger")
                                                             'OUTPUT]
                       (T (SETQ OUTPUTSTREAM (GETSTREAM T 'OUTPUT]
                    (COND
                       ((NOT MYFILE)
                        [SETQ MYFILE (CL:WITH-OPEN-FILE (TESTFILE TESTFILE :DIRECTION :INPUT)
                                            (COPYFILE TESTFILE (PACKFILENAME 'EXTENSION 'FBTESTER
                                                                      'VERSION NIL 'BODY TESTFILE]
                        (BINCOM MYFILE TESTFILE OPTION OUTPUTSTREAM)))
                    [SETQ TMPFILENAME (OR DESTINATION (PACKFILENAME 'EXTENSION 'FBTEMP 'VERSION NIL
                                                             'BODY
                                                             (OR MYFILE 'FILEBANGER]
                LP  (PRIN1 (add LOOPCNT 1)
                           OUTPUTSTREAM)
                    (RESETLST [RESETSAVE (SETQ NEWFILE (OPENFILE TMPFILENAME 'OUTPUT NIL NIL OUTPARMS
                                                              ))
                                     '(PROGN (CLOSEF OLDVALUE]
                           (CL:WITH-OPEN-FILE (MYFILE MYFILE :DIRECTION :INPUT)
                                  (COPYBYTES MYFILE NEWFILE)))
                    (AND LASTFILE (DELFILE LASTFILE))
                    [RPTQ FBREPEATCOUNT (PROGN (BLOCK)
                                               (PRIN1 '%. OUTPUTSTREAM)
                                               (COND
                                                  ((NEQ (BINCOM MYFILE NEWFILE OPTION OUTPUTSTREAM)
                                                        T)
                                                   (add ERRCNT 1]
                    (SETQ LASTFILE NEWFILE)
                    (BLOCK)
                    (GO LP])

(FBCOPYBYTES
  [LAMBDA (INSTREAM ECHOSTREAM START)                        (* bvm%: "24-JUN-83 19:00")
    (SETFILEPTR INSTREAM START)
    (RPTQ 40 (\OUTCHAR ECHOSTREAM (\BIN INSTREAM])

(FBMAKETESTFILE
  [LAMBDA (LENGTH NAME)                                    (* ; "Edited  1-Oct-87 18:20 by Daniels")

    (LET ((PATHNAME))
         [CL:WITH-OPEN-FILE (FILE (OR NAME "FILEBANGER.TMP")
                                  :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
                (SETQ PATHNAME (CL:TRUENAME FILE))
                (for I from 1 to (OR LENGTH 1000) do (\OUTCHAR FILE (RAND 32 127]
         PATHNAME])

(MAKEBANGERWINDOW
  [LAMBDA (FILE TYPE)                                        (* bvm%: "12-AUG-83 13:06")
    (PROG (W)
          [RESETSAVE (TTYDISPLAYSTREAM (SETQ W (CREATEW NIL (CONCAT TYPE " for " FILE]
          (DSPFONT '(GACHA 8) W)
          [WINDOWPROP W 'CLOSEFN (FUNCTION (LAMBDA (W P)
                                             (AND [PROCESSP (SETQ P (WINDOWPROP W 'PROCESS]
                                                  (PROCESS.EVAL P '(ERROR!]
          (WINDOWPROP W 'PAGEFULLFN (FUNCTION NILL))
          (RETURN W])

(MAKEFILEBANGER
  [LAMBDA (TESTFILE)                                         (* bvm%: "14-AUG-83 13:56")
    (DECLARE (SPECVARS ERRCNT LOOPCNT))
    (RESETLST (PROG ((LOOPCNT 0)
                     NEWFILE LASTFILE)
                    [SETQ TESTFILE (LOADFROM (OR TESTFILE (RETURN "No TESTFILE supplied"]
                    (MAKEBANGERWINDOW TESTFILE "MAKEFILE Banger")
                    (SETQ TESTFILE (NAMEFIELD TESTFILE T))
                LP  (SETQ NEWFILE (MAKEFILE TESTFILE))
                    (AND (CHECKFORZEROS NEWFILE)
                         (HELP "Zeros found"))
                    [COND
                       (LASTFILE (DELFILE LASTFILE)
                              (REMPROP LASTFILE 'PAGES]
                    (SETQ LASTFILE NEWFILE)
                    (GO LP])

(ZEROBANGER
  [LAMBDA (TESTFILE1 TESTFILE2 TMPFILENAME N NOBREAK OUTPUTSTREAM)
                                                             (* bvm%: "12-AUG-83 13:07")
    (DECLARE (SPECVARS ERRCNT LOOPCNT))
    (RESETLST (PROG ((ERRCNT 0)
                     (LOOPCNT 0)
                     (OPTION (AND (NOT NOBREAK)
                                  'BREAK))
                     THISFILE NEWFILE LASTFILE)
                    [SETQ THISFILE (CLOSEF (SETQ TESTFILE1 (OPENFILE (OR TESTFILE1 (RETURN 
                                                                               "No TESTFILE supplied"
                                                                                          ))
                                                                  'INPUT]
                    (RESETSAVE NIL (LIST 'CLOSEF? TESTFILE1))
                    [CLOSEF (SETQ TESTFILE2 (OPENFILE (OR TESTFILE2 (RETURN "No TESTFILE supplied"))
                                                   'INPUT]
                    (RESETSAVE NIL (LIST 'CLOSEF? TESTFILE2))
                    [CLOSEF (SETQ TMPFILENAME (OPENFILE (OR TMPFILENAME 'ZEROBANGER.TMP)
                                                     'OUTPUT]
                    (RESETSAVE NIL (LIST 'CLOSEF? TMPFILENAME))
                    (SETQ OUTPUTSTREAM (GETSTREAM (OR OUTPUTSTREAM (MAKEBANGERWINDOW THISFILE 
                                                                          "Zero Banger"))
                                              'OUTPUT))
                LP  (COND
                       ((AND N (ILESSP (add N -1)
                                      0))
                        (RETURN ERRCNT)))
                    (printout OUTPUTSTREAM (add LOOPCNT 1)
                           %,)
                    (OPENFILE TMPFILENAME 'BOTH 'OLD)
                    (OPENFILE THISFILE 'INPUT)
                    (COPYBYTES THISFILE TMPFILENAME 0 -1)
                    (CLOSEF THISFILE)
                    (SETFILEINFO TMPFILENAME 'LENGTH (GETFILEPTR TMPFILENAME))
                    (CLOSEF TMPFILENAME)                     (* (AND LASTFILE (DELFILE LASTFILE)))
                    (COND
                       ((NEQ (BINCOM THISFILE TMPFILENAME OPTION OUTPUTSTREAM)
                             T)
                        (add ERRCNT 1)))                     (* (SETQ LASTFILE NEWFILE))
                    (SETQ THISFILE (COND
                                      ((EQ THISFILE TESTFILE1)
                                       TESTFILE2)
                                      (T TESTFILE1)))
                    (GO LP])

(SUSPEND.FILEBANGER
  [LAMBDA NIL                                                (* bvm%: "10-AUG-83 17:39")
    (for PROC in FILEBANGERS when (AND (PROCESSP PROC)
                                       (NEQ PROC (THIS.PROCESS))) do (SUSPEND.PROCESS PROC))
    (CLOSEF (PROG1 PUPTRACEFILE (SETQ PUPTRACEFILE (PUPTRACE PUPTRACEFLG '(832 416 190 336])

(WATCHDISKPAGES
  [LAMBDA (THRESHOLD)                                        (* bvm%: "10-AUG-83 17:11")
    (OR THRESHOLD (SETQ THRESHOLD 2000))
    (while T bind (MARGIN _ THRESHOLD)
                  LASTFILE do (COND
                                 ((ILESSP (DISKFREEPAGES)
                                         (IPLUS THRESHOLD MARGIN))
                                  (COND
                                     (LASTFILE (DELFILE LASTFILE)))
                                  (SETQ LASTFILE (CLOSEF PUPTRACEFILE))
                                  (SETQ PUPTRACEFILE (OPENFILE '{DSK}PUPTRACE.TMP 'OUTPUT
                                                            'NEW))
                                  (SETQ MARGIN 0)))
                              (BLOCK 60000])
)
(DEFINEQ

(BINCOM
  [LAMBDA (FILE1 FILE2 OPTION OUTPUTSTREAM)                (* ; "Edited  1-Oct-87 18:36 by Daniels")

    (RESETLST (PROG ((STRM1 (OPENSTREAM FILE1 'INPUT 'OLD))
                     (STRM2 (OPENSTREAM FILE2 'INPUT 'OLD))
                     HERE B1 B2)
                    (RESETSAVE NIL (LIST 'CLOSEF STRM1))
                    (RESETSAVE NIL (LIST 'CLOSEF STRM2))
                    (SETQ OUTPUTSTREAM (GETSTREAM (OR OUTPUTSTREAM T)
                                              'OUTPUT))
                    (RETURN (COND
                               ((IEQP (GETEOFPTR STRM1)
                                      (GETEOFPTR STRM2))
                                (for I from 1 to (GETEOFPTR STRM1)
                                   do (IF (ZEROP (MOD I 5120))
                                          THEN (BLOCK))
                                      (COND
                                         ((NEQ (SETQ B1 (\BIN STRM1))
                                               (SETQ B2 (\BIN STRM2)))
                                          (COND
                                             ((NEQ OPTION 'NOMSG)
                                              (printout OUTPUTSTREAM T (FULLNAME STRM1)
                                                     " and "
                                                     (FULLNAME STRM2)
                                                     " differ at byte " |.P2| (SETQ HERE
                                                                               (SUB1 (GETFILEPTR
                                                                                      STRM1)))
                                                     " (page " |.P2| (fetch (BYTEPTR PAGE)
                                                                        of HERE)
                                                     ", byte " |.P2| (fetch (BYTEPTR OFFSET)
                                                                        of HERE)
                                                     "): ")
                                              (\OUTCHAR OUTPUTSTREAM B1)
                                              (printout OUTPUTSTREAM "[" |.P2| B1 "] vs. ")
                                              (\OUTCHAR OUTPUTSTREAM B2)
                                              (printout OUTPUTSTREAM "[" |.P2| B2 "]" T (FULLNAME
                                                                                         STRM1)
                                                     " reads:" T)
                                              (FBCOPYBYTES STRM1 OUTPUTSTREAM HERE)
                                              (printout OUTPUTSTREAM T (FULLNAME STRM2)
                                                     " reads:" T)
                                              (FBCOPYBYTES STRM2 OUTPUTSTREAM HERE)
                                              (TERPRI T)))
                                          (COND
                                             ((EQ OPTION 'BREAK)
                                              (HELP STRM1 STRM2)))
                                          (RETURN I))) finally (RETURN T)))
                               (T (COND
                                     ((NEQ OPTION 'NOMSG)
                                      (printout OUTPUTSTREAM T (FULLNAME STRM1)
                                             " has length " |.P2| (GETEOFPTR STRM1)
                                             ", but "
                                             (FULLNAME STRM2)
                                             " has length " |.P2| (GETEOFPTR STRM2)
                                             T)))
                                  (COND
                                     ((EQ OPTION 'BREAK)
                                      (HELP STRM1 STRM2)))
                                  (LIST (GETEOFPTR STRM1)
                                        (GETEOFPTR STRM2])
)
(DEFINEQ

(CHECKFORZEROS
  [LAMBDA (FILE MINZEROS)                                (* ; "Edited 14-Jun-90 21:18 by jds")
    (RESETLST
        (PROG ((STREAM (OPENSTREAM FILE 'INPUT))
               (%#FAILURES 0)
               N)
              (RESETSAVE NIL (LIST 'CLOSEF STREAM))
              (OR MINZEROS (SETQ MINZEROS 20))
              (replace (STREAM ENDOFSTREAMOP) of STREAM with (FUNCTION NILL))
              (printout T (FULLNAME STREAM)
                     ": " T)
              (do (SELECTQ (BIN STREAM)
                          (NIL (RETURN))
                          (0 (SETQ N 1)
                             (while (ZEROP (BIN STREAM)) do (add N 1))
                             (COND
                                ((IGREATERP N MINZEROS)
                                 (printout T |.P2| N " zeros starting at byte " |.P2|
                                        (SUB1 (IDIFFERENCE (GETFILEPTR STREAM)
                                                     N))
                                        T)
                                 (add %#FAILURES 1))))
                          NIL))
              (RETURN (AND (NOT (ZEROP %#FAILURES))
                           %#FAILURES))))])
)

(RPAQ? FBREPEATCOUNT 4)

(RPAQ? FILEBANGERS )

(PUTPROPS FILEBANGER FILETYPE :COMPILE-FILE)
(PUTPROPS FILEBANGER COPYRIGHT ("Venue & Xerox Corporation" 1983 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (853 10546 (DOFILEBANGER 863 . 1083) (DOMAKEFILEBANGER 1085 . 1282) (DOZEROBANGER 1284
 . 1606) (FILEBANGER 1608 . 4686) (FBCOPYBYTES 4688 . 4884) (FBMAKETESTFILE 4886 . 5345) (
MAKEBANGERWINDOW 5347 . 5899) (MAKEFILEBANGER 5901 . 6714) (ZEROBANGER 6716 . 9360) (
SUSPEND.FILEBANGER 9362 . 9739) (WATCHDISKPAGES 9741 . 10544)) (10547 14583 (BINCOM 10557 . 14581)) (
14584 15841 (CHECKFORZEROS 14594 . 15839)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/FILEBANGER.DFASL b/internal/library/OBSOLETE/FILEBANGER.DFASL
new file mode 100644
index 00000000..356f4c9b
Binary files /dev/null and b/internal/library/OBSOLETE/FILEBANGER.DFASL differ
diff --git a/internal/library/OBSOLETE/FLOPPYTESTER b/internal/library/OBSOLETE/FLOPPYTESTER
new file mode 100644
index 00000000..10c7162c
--- /dev/null
+++ b/internal/library/OBSOLETE/FLOPPYTESTER
@@ -0,0 +1 @@
+(FILECREATED "24-Mar-86 15:18:14" {ERIS}<LISPCORE>SOURCES>FLOPPYTESTER.;9 4308   

      changes to:  (FNS STARTTEST STOPTEST KILLTEST)
		   (VARS FLOPPYTESTERCOMS)

      previous date: "20-Mar-86 21:06:46" {ERIS}<LISPCORE>SOURCES>FLOPPYTESTER.;5)


(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT FLOPPYTESTERCOMS)

(RPAQQ FLOPPYTESTERCOMS ((* * FLOPPYTESTER -- Runs FILEBANGER on FLOPPY. *)
			   (P (LOAD? (QUOTE {ERINYES}<TEST>TOOLS>FILEBANGER.DCOM)))
			   (INITVARS (ALLOCATIONSW NIL))
			   (FNS STARTTEST STOPTEST KILLTEST BLTALLOCS BLTALLOC)))
(* * FLOPPYTESTER -- Runs FILEBANGER on FLOPPY. *)

(LOAD? (QUOTE {ERINYES}<TEST>TOOLS>FILEBANGER.DCOM))

(RPAQ? ALLOCATIONSW NIL)
(DEFINEQ

(STARTTEST
  (LAMBDA (N)                                                (* kbr: "24-Mar-86 15:15")
    (SETQ STARTTIME (GDATE))
    (CNDIR (QUOTE {FLOPPY}))
    (FLOPPY.FORMAT (QUOTE TEST))
    (DIRECTORY (QUOTE {FLOPPY}*))
    (BLTALLOCS)
    (for I from 1 to N do (DOFILEBANGER (PACK* (QUOTE {FLOPPY})
							   (QUOTE TESTFILE)
							   I)
						  (RAND 10 30)))))

(STOPTEST
  (LAMBDA NIL                                                (* kbr: "24-Mar-86 15:16")
    (SETQ STOPTIME (GDATE))
    (for P in FILEBANGERS when (NOT (EQ P (THIS.PROCESS))) do (SUSPEND.PROCESS P))))

(KILLTEST
  (LAMBDA NIL                                                (* kbr: "22-Mar-86 17:18")
    (for P in FILEBANGERS do (DEL.PROCESS P))
    (SETQ FILEBANGERS NIL)))

(BLTALLOCS
  [LAMBDA NIL                                                (* kbr: "18-Nov-85 12:32")
                                                             (* Debugging fn. Puts up a window representation of 
							     allocations on floppy. *)
    (PROG (PIXELS XLENGTH YLENGTH)
	    (SETQ PIXELS 5)
	    (SETQ XLENGTH (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK))
	    (SETQ YLENGTH \FLOPPY.CYLINDERS)
	    [COND
	      ((NULL ALLOCATIONSW)
		(SETQ ALLOCATIONSW (CREATEW (GETBOXREGION (WIDTHIFWINDOW (ITIMES PIXELS 
											  XLENGTH))
								(HEIGHTIFWINDOW (ITIMES PIXELS 
											  YLENGTH)
										  T)
								NIL NIL NIL 
							     "Position FLOPPY ALLOCATIONS window")
						"FLOPPY ALLOCATIONS"))
		(UNADVISE (QUOTE \PFLOPPY.ALLOCATE))
		(ADVISE (QUOTE \PFLOPPY.ALLOCATE)
			  (QUOTE AFTER)
			  (QUOTE (COND (!VALUE (BLTALLOC !VALUE]
	    (BITBLT NIL NIL NIL ALLOCATIONSW NIL NIL NIL NIL (QUOTE TEXTURE)
		      (QUOTE REPLACE)
		      WHITESHADE)
	    (for Y from 0 to (SUB1 YLENGTH) do (for X from 0 to (SUB1 XLENGTH)
							    do (BITMAPBIT ALLOCATIONSW
									      (ITIMES PIXELS X)
									      (ITIMES PIXELS Y)
									      1)))
	    (for PFALLOC in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV)
	       when [NOT (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC)
				      (QUOTE (FREE]
	       do (BLTALLOC PFALLOC])

(BLTALLOC
  [LAMBDA (PFALLOC)                                          (* kbr: "18-Nov-85 12:21")
    (PROG (SHADE OPSHADE LEFT BOTTOM PIXELS XLENGTH)
	    (SETQ PIXELS 5)
	    (SETQ XLENGTH (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK))
	    (SETQ SHADE (COND
		((EQUAL (fetch (PFALLOC FILENAME) of PFALLOC)
			  (QUOTE (FREE)))
		  WHITESHADE)
		(T BLACKSHADE)))
	    (SETQ OPSHADE (IDIFFERENCE BLACKSHADE SHADE))
	    (for I from (fetch (PFALLOC START) of PFALLOC) to (fetch (PFALLOC END)
									   of PFALLOC)
	       do (SETQ LEFT (ITIMES PIXELS (IREMAINDER (SUB1 I)
								XLENGTH)))
		    (SETQ BOTTOM (ITIMES PIXELS (IQUOTIENT (SUB1 I)
								 XLENGTH)))
		    (BLTSHADE SHADE ALLOCATIONSW LEFT BOTTOM PIXELS PIXELS (QUOTE REPLACE))
		    (BLTSHADE OPSHADE ALLOCATIONSW LEFT BOTTOM 1 1 (QUOTE REPLACE])
)
(PUTPROPS FLOPPYTESTER COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (745 4220 (STARTTEST 755 . 1203) (STOPTEST 1205 . 1463) (KILLTEST 1465 . 1665) (
BLTALLOCS 1667 . 3253) (BLTALLOC 3255 . 4218)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/FLOPPYWORK b/internal/library/OBSOLETE/FLOPPYWORK
new file mode 100644
index 00000000..e6ffbf45
--- /dev/null
+++ b/internal/library/OBSOLETE/FLOPPYWORK
@@ -0,0 +1 @@
+(FILECREATED "19-Jun-86 12:32:16" {ERIS}<LISPCORE>SOURCES>FLOPPYWORK.;1 3836   

      changes to:  (VARS FLOPPYWORKCOMS)
                   (FNS \PFLOPPY.SCAVENGE.PMPAGE.AFTER1))


(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT FLOPPYWORKCOMS)

(RPAQQ FLOPPYWORKCOMS ((FNS \PFLOPPY.SCAVENGE.PMPAGE.AFTER1)))
(DEFINEQ

(\PFLOPPY.SCAVENGE.PMPAGE.AFTER1
  (LAMBDA (PLOCATION PPMPAGE LOCATION PMPAGE)                (* kbr: "19-Jun-86 12:29")
    (PROG (LENGTH TYPE FILETYPE FILEID)
        RETRY
            (COND
              ((NOT (\PFLOPPY.READPAGENO LOCATION PMPAGE T))
                                                             (* Couldn't read this LOCATION.
                                                             Assume misformatted track. *)
                (GLOBALRESOURCE \FLOPPY.IBMD512.FLOPPYIOCB (\FLOPPY.FORMATTRACKS 
                                                                       \FLOPPY.IBMD512.FLOPPYIOCB
                                                                                   (
                                                                     \PFLOPPY.PAGENOTODISKADDRESS
                                                                                     LOCATION)
                                                                                   1 T))
                (GO RETRY)))
            (COND
              ((NOT (OR (fetch (PMPAGE INTACT) of PMPAGE)
                            (IEQP LOCATION \PFLOPPYLASTDATAPAGE)))
                (RETURN)))                                 (* Force PMPAGE to be a legal marker page.
                                                             *)
            (replace (PMPAGE SEAL) of PMPAGE with SEAL.PMPAGE)
            (replace (PMPAGE VERSION) of PMPAGE with VERSION.PMPAGE)
            (SETQ LENGTH (IPLUS LOCATION (IMINUS PLOCATION)
                                    -1))
            (COND
              ((ZEROP LENGTH)
                (SETQ TYPE PMPAGEETYPE.FREE)
                (SETQ FILETYPE FILETYPE.FREE)
                (SETQ FILEID 0))
              (T (SETQ TYPE (fetch (PMPAGE NTYPE) of PPMPAGE))
                 (SETQ FILETYPE (fetch (PMPAGE NFILETYPE) of PPMPAGE))
                 (SETQ FILEID (COND
                     ((EQ TYPE PMPAGEETYPE.PFILELIST)
                       1)
                     (T 0)))))
            (replace (PMPAGE PLENGTH) of PMPAGE with LENGTH)
            (replace (PMPAGE PTYPE) of PMPAGE with TYPE)
            (replace (PMPAGE PFILETYPE) of PMPAGE with FILETYPE)
            (replace (PMPAGE PFILEID) of PMPAGE with FILEID)
                                                             (* Fix PPMPAGE wrt PMPAGE now *)
            (replace (PMPAGE NLENGTH) of PPMPAGE with LENGTH)
            (replace (PMPAGE NTYPE) of PPMPAGE with TYPE)
            (replace (PMPAGE NFILETYPE) of PPMPAGE with FILETYPE)
            (replace (PMPAGE NFILEID) of PPMPAGE with FILEID)
            (\PFLOPPY.WRITEPAGENO PLOCATION PPMPAGE)
            (COND
              ((IEQP LOCATION \PFLOPPYLASTDATAPAGE)
                (replace (PMPAGE NLENGTH) of PMPAGE with 0)
                (replace (PMPAGE NTYPE) of PMPAGE with PMPAGEETYPE.FREE)
                (replace (PMPAGE NFILETYPE) of PMPAGE with FILETYPE.FREE)
                (replace (PMPAGE NFILEID) of PMPAGE with 0)
                (\PFLOPPY.WRITEPAGENO LOCATION PMPAGE))))))
)
(PUTPROPS FLOPPYWORK COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (355 3755 (\PFLOPPY.SCAVENGE.PMPAGE.AFTER1 365 . 3753)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/GRAPEVINE b/internal/library/OBSOLETE/GRAPEVINE
new file mode 100644
index 00000000..6215ffc0
--- /dev/null
+++ b/internal/library/OBSOLETE/GRAPEVINE
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 14:49:16" {DSK}<usr>local>lde>lispcore>internal>library>GRAPEVINE.;2 50497  

      changes to%:  (VARS GRAPEVINECOMS)
                    (FNS \ENQUIRE \PERFORMGVOP FINDREGSERVER GV.KILLSOCKET \GV.WHENCLOSED)

      previous date%: "21-May-86 10:53:33" {DSK}<usr>local>lde>lispcore>internal>library>GRAPEVINE.;1
)


(* ; "
Copyright (c) 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT GRAPEVINECOMS)

(RPAQQ GRAPEVINECOMS
       [(COMS (* Functions for interrogating the database)
              (FNS GV.AUTHENTICATE GV.CHECKSTAMP GV.EXPAND GV.IDENTIFYCALLER GV.IDENTIFYME 
                   GV.ISINLIST GV.ISMEMBERCLOSURE GV.ISMEMBERDIRECT GV.READCONNECT GV.READENTRY 
                   GV.READFRIENDS GV.READMEMBERS GV.READOWNERS GV.READREMARK)
              (* Functions which update the database)
              (FNS GV.ADDFORWARD GV.ADDFRIEND GV.ADDLISTOFMEMBERS GV.ADDMAILBOX GV.ADDMEMBER 
                   GV.ADDOWNER GV.CHANGECONNECT GV.CHANGEPASSWORD GV.CHANGEREMARK GV.CREATEGROUP 
                   GV.CREATEINDIVIDUAL GV.DELETEGROUP GV.DELETEINDIVIDUAL GV.NEWNAME GV.REMOVEFORWARD
                   GV.REMOVEFRIEND GV.REMOVEMAILBOX GV.REMOVEMEMBER GV.REMOVEOWNER))
        (COMS (* Talking to Reg Servers)
              (FNS \GVOP \ENQUIRE \PERFORMGVOP FINDREGSERVER LOCATESOCKETS)
              (ADDVARS (\GVCONNECTIONS))
              (VARS (REGROOT '(GV . GV))
                    (REGROOTNLSNAME "GrapevineRServer")
                    (\REG.IOTIMEOUT 30000))
              (DECLARE%: DOEVAL@COMPILE DONTCOPY (COMS * GVPROTOCOLDEFS)))
        (COMS (* Making server connections)
              (FNS OPENCLOSESTSOCKET \OPENGVCONNECTION GV.KILLSOCKET \GV.WHENCLOSED)
              (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS GVCONNECTION)
                     (CONSTANTS (\DEFAULTPOLLINGSOC 5))
                     (GLOBALVARS \BETWEENPROBEDELAY \CONNECTTIMEOUT))
              (VARS (\BETWEENPROBEDELAY 1000)
                    (\CONNECTTIMEOUT 30000)))
        (COMS (* Checking arguments)
              (FNS \CHECKNAME \CHECKSTRING \NONAMEERR \UNPACKREG)
              (INITVARS (DEFAULTREGISTRY))
              (GLOBALVARS DEFAULTREGISTRY))
        (COMS (* GVKEY)
              (FNS \CHECKKEY GV.MAKEKEY)
              (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS GVKEY)
                     (CONSTANTS \#BYTES.GVKEY)
                     (MACROS KEYP CREATEKEY GETKEYBYTE SETKEYBYTE))
              (INITRECORDS GVKEY))
        [COMS (* TIMESTAMP)
              (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS TIMESTAMP)
                     (CONSTANTS \#BYTES.TIMESTAMP))
              (INITRECORDS TIMESTAMP)
              (FNS \TIMESTAMP.DEFPRINT \CHECKSTAMP)
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'TIMESTAMP '\TIMESTAMP.DEFPRINT]
        (COMS (* I/O primitives)
              (FNS \SENDITEM \SENDSTRING)
              (FNS \RECEIVEBOOL \RECEIVECLIST \RECEIVECOMPONENT \RECEIVERLIST \RECEIVERNAME 
                   \RECEIVESTAMP \RECEIVESTRING)
              (VARS (\3BYTEKLUDGEKEY '$$3byte$$))
              (DECLARE%: DOEVAL@COMPILE DONTCOPY (MACROS \RECEIVEWORD \SKIPWORD \SENDWORD)
                     (CONSTANTS (\MAXGVSTRING 64))
                     (GLOBALVARS \3BYTEKLUDGEKEY)))
        (DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (P (SELECTQ (COMPILEMODE)
                                                                 (D (FILESLOAD (LOADCOMP)
                                                                           PUP BSP))
                                                                 (PDP-10 (FILESLOAD (LOADCOMP)
                                                                                PUP10 BSPAUX))
                                                                 NIL])



(* Functions for interrogating the database)

(DEFINEQ

(GV.AUTHENTICATE
  [LAMBDA (NAME KEY)                                     (* ht%: "14-JAN-82 10:24")
    (\GVOP \OP.AUTHENTICATE (\CHECKNAME NAME)
           (LIST (\CHECKKEY KEY])

(GV.CHECKSTAMP
  [LAMBDA (NAME OLDSTAMP)                                (* ht%: "22-JAN-82 10:07")
    (\GVOP \OP.CHECKSTAMP (\CHECKNAME NAME)
           (LIST (\CHECKSTAMP OLDSTAMP))
           (FUNCTION \RECEIVESTAMP])

(GV.EXPAND
  [LAMBDA (NAME OLDSTAMP)                                (* M.Yonke "10-AUG-83 11:10")

         (* Does the database Expand operation -
       named to avoid conflict with the mail server version
       (MSExpand))

    (\GVOP \OP.GVEXPAND (\CHECKNAME NAME)
           (LIST (\CHECKSTAMP OLDSTAMP))
           (FUNCTION \RECEIVERLIST])

(GV.IDENTIFYCALLER
  [LAMBDA (NAME KEY)                                     (* ht%: "14-JAN-82 10:27")
    (\GVOP \OP.IDENTIFYCALLER (\CHECKNAME NAME)
           (LIST (\CHECKKEY KEY])

(GV.IDENTIFYME
  [LAMBDA NIL                                            (* bvm%: "17-SEP-83 14:14")
                                                             (* Calls GV.IDENTIFYCALLER with info 
                                                           provided by LOGIN)
    (PROG ((npw (\INTERNAL/GETPASSWORD NIL)))
          (RETURN (GV.IDENTIFYCALLER (CAR npw)
                         (CDR npw])

(GV.ISINLIST
  [LAMBDA (GROUP MEMBER WHAT WHICH WHERE)            (* bvm%: "21-May-86 10:34")
    (\GVOP \OP.ISINLIST (\CHECKNAME GROUP)
           (LIST (\CHECKSTRING MEMBER)
                 (LIST \3BYTEKLUDGEKEY (OR WHAT OP.ITSELF)
                       (OR WHICH OP.MEMBERS)
                       (OR WHERE OP.DIRECT)))
           (FUNCTION \RECEIVEBOOL])

(GV.ISMEMBERCLOSURE
  [LAMBDA (GROUP MEMBER)                             (* bvm%: "21-May-86 10:34")
    (\GVOP \OP.ISMEMBERCLOSURE (\CHECKNAME GROUP)
           (LIST (\CHECKSTRING MEMBER))
           (FUNCTION \RECEIVEBOOL])

(GV.ISMEMBERDIRECT
  [LAMBDA (GROUP MEMBER)                             (* bvm%: "21-May-86 10:34")
    (\GVOP \OP.ISMEMBERDIRECT (\CHECKNAME GROUP)
           (LIST (\CHECKSTRING MEMBER))
           (FUNCTION \RECEIVEBOOL])

(GV.READCONNECT
  [LAMBDA (NAME)                                         (* ht%: "14-JAN-82 10:20")
    (\GVOP \OP.READCONNECT (\CHECKNAME NAME)
           NIL
           (FUNCTION \RECEIVERNAME])

(GV.READENTRY
  [LAMBDA (NAME OLDSTAMP READFN)                         (* bvm%: "22-Mar-84 14:05")
    (\GVOP \OP.READENTRY (\CHECKNAME NAME)
           (LIST (\CHECKSTAMP OLDSTAMP))
           (OR READFN (FUNCTION \RECEIVECLIST])

(GV.READFRIENDS
  [LAMBDA (NAME OLDSTAMP READFN)                         (* bvm%: "22-Mar-84 14:03")
    (\GVOP \OP.READFRIENDS (\CHECKNAME NAME)
           (LIST (\CHECKSTAMP OLDSTAMP))
           (OR READFN (FUNCTION \RECEIVERLIST])

(GV.READMEMBERS
  [LAMBDA (NAME OLDSTAMP READFN)                         (* bvm%: "22-Mar-84 14:03")
    (\GVOP \OP.READMEMBERS (\CHECKNAME NAME)
           (LIST (\CHECKSTAMP OLDSTAMP))
           (OR READFN (FUNCTION \RECEIVERLIST])

(GV.READOWNERS
  [LAMBDA (NAME OLDSTAMP READFN)                         (* bvm%: "22-Mar-84 14:04")
    (\GVOP \OP.READOWNERS (\CHECKNAME NAME)
           (LIST (\CHECKSTAMP OLDSTAMP))
           (OR READFN (FUNCTION \RECEIVERLIST])

(GV.READREMARK
  [LAMBDA (NAME)                                         (* ht%: "14-JAN-82 10:21")
    (\GVOP \OP.READREMARK (\CHECKNAME NAME)
           NIL
           (FUNCTION \RECEIVERNAME])
)



(* Functions which update the database)

(DEFINEQ

(GV.ADDFORWARD
  [LAMBDA (NAME STRING IDENTIFYUSER PASSWORD)            (* bvm%: "16-SEP-83 18:28")
    (\GVOP \OP.ADDFORWARD (\CHECKNAME NAME)
           (LIST (\CHECKSTRING STRING))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.ADDFRIEND
  [LAMBDA (GROUP FRIEND IDENTIFYUSER PASSWORD)           (* bvm%: "21-May-86 10:38")
    (\GVOP \OP.ADDFRIEND (\CHECKNAME GROUP)
           (LIST (\CHECKSTRING FRIEND))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.ADDLISTOFMEMBERS
  [LAMBDA (GROUP MEMBERS IDENTIFYUSER PASSWORD)          (* bvm%: "21-May-86 10:39")
    (\GVOP \OP.ADDLISTOFMEMBERS (\CHECKNAME GROUP)
           [LIST (COND
                    ([AND (LISTP MEMBERS)
                          (OR (STRINGP (CAR MEMBERS))
                              (LITATOM (CAR MEMBERS)))
                          (for p on MEMBERS when (CDR p)
                             always (AND (OR (STRINGP (CADR p))
                                                 (LITATOM (CADR p)))
                                             (ALPHORDER (CAR p)
                                                    (CADR p]
                     MEMBERS)
                    (T (ERROR "must have ordered list of strings" MEMBERS]
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.ADDMAILBOX
  [LAMBDA (NAME STRING IDENTIFYUSER PASSWORD)            (* bvm%: "16-SEP-83 18:20")
    (\GVOP \OP.ADDMAILBOX (\CHECKNAME NAME)
           (LIST (\CHECKSTRING STRING))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.ADDMEMBER
  [LAMBDA (GROUP MEMBER IDENTIFYUSER PASSWORD)       (* bvm%: "21-May-86 10:39")
    (\GVOP \OP.ADDMEMBER (\CHECKNAME GROUP)
           (LIST (\CHECKSTRING MEMBER))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.ADDOWNER
  [LAMBDA (GROUP OWNER IDENTIFYUSER PASSWORD)            (* bvm%: "21-May-86 10:39")
    (\GVOP \OP.ADDOWNER (\CHECKNAME GROUP)
           (LIST (\CHECKSTRING OWNER))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.CHANGECONNECT
  [LAMBDA (NAME SITE IDENTIFYUSER PASSWORD)              (* bvm%: "16-SEP-83 18:27")
    (\GVOP \OP.CHANGECONNECT (\CHECKNAME NAME)
           [LIST (OR (STRINGP SITE)
                     (AND (LITATOM SITE)
                          SITE)
                     (COND
                        ((AND [OR (LISTP SITE)
                                  (NUMBERP SITE)
                                  (AND (NOT SITE)
                                       (SETQ SITE (\LOCALPUPADDRESS]
                              (PORTSTRING SITE)))
                        (T (ERROR "Invalid Site" SITE]
           NIL IDENTIFYUSER PASSWORD])

(GV.CHANGEPASSWORD
  [LAMBDA (NAME KEY IDENTIFYUSER PASSWORD)               (* bvm%: "16-SEP-83 18:21")
    (\GVOP \OP.CHANGEPASSWORD (\CHECKNAME NAME)
           (LIST (\CHECKKEY KEY))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.CHANGEREMARK
  [LAMBDA (NAME STRING IDENTIFYUSER PASSWORD)            (* bvm%: "16-SEP-83 18:22")
    (\GVOP \OP.CHANGEREMARK (\CHECKNAME NAME)
           (LIST (\CHECKSTRING STRING))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.CREATEGROUP
  [LAMBDA (NAME IDENTIFYUSER PASSWORD)                   (* bvm%: "16-SEP-83 18:22")
    (\GVOP \OP.CREATEGROUP (\CHECKNAME NAME)
           NIL NIL (OR IDENTIFYUSER T)
           PASSWORD])

(GV.CREATEINDIVIDUAL
  [LAMBDA (NAME KEY IDENTIFYUSER PASSWORD)               (* bvm%: "16-SEP-83 18:23")
    (\GVOP \OP.CREATEINDIVIDUAL (\CHECKNAME NAME)
           (LIST (\CHECKKEY KEY))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.DELETEGROUP
  [LAMBDA (NAME IDENTIFYUSER PASSWORD)                   (* bvm%: "16-SEP-83 18:23")
    (\GVOP \OP.DELETEGROUP (\CHECKNAME NAME)
           NIL NIL (OR IDENTIFYUSER T)
           PASSWORD])

(GV.DELETEINDIVIDUAL
  [LAMBDA (NAME IDENTIFYUSER PASSWORD)                   (* bvm%: "16-SEP-83 18:23")
    (\GVOP \OP.DELETEINDIVIDUAL (\CHECKNAME NAME)
           NIL NIL (OR IDENTIFYUSER T)
           PASSWORD])

(GV.NEWNAME
  [LAMBDA (NAME GV.NEWNAME IDENTIFYUSER PASSWORD)        (* bvm%: "16-SEP-83 18:24")
    (\GVOP \OP.NEWNAME (\CHECKNAME NAME)
           (LIST (\CHECKNAME GV.NEWNAME))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.REMOVEFORWARD
  [LAMBDA (NAME STRING IDENTIFYUSER PASSWORD)            (* bvm%: "16-SEP-83 18:24")
    (\GVOP \OP.REMOVEFORWARD (\CHECKNAME NAME)
           (LIST (\CHECKSTRING STRING))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.REMOVEFRIEND
  [LAMBDA (GROUP FRIEND IDENTIFYUSER PASSWORD)           (* bvm%: "21-May-86 10:40")
    (\GVOP \OP.REMOVEFRIEND (\CHECKNAME GROUP)
           (LIST (\CHECKSTRING FRIEND))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.REMOVEMAILBOX
  [LAMBDA (NAME STRING IDENTIFYUSER PASSWORD)            (* bvm%: "16-SEP-83 18:25")
    (\GVOP \OP.REMOVEMAILBOX (\CHECKNAME NAME)
           (LIST (\CHECKSTRING STRING))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.REMOVEMEMBER
  [LAMBDA (GROUP MEMBER IDENTIFYUSER PASSWORD)       (* bvm%: "21-May-86 10:40")
    (\GVOP \OP.REMOVEMEMBER (\CHECKNAME GROUP)
           (LIST (\CHECKSTRING MEMBER))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])

(GV.REMOVEOWNER
  [LAMBDA (GROUP OWNER IDENTIFYUSER PASSWORD)            (* bvm%: "21-May-86 10:40")
    (\GVOP \OP.REMOVEOWNER (\CHECKNAME GROUP)
           (LIST (\CHECKSTRING OWNER))
           NIL
           (OR IDENTIFYUSER T)
           PASSWORD])
)



(* Talking to Reg Servers)

(DEFINEQ

(\GVOP
  [LAMBDA (OP name itemList READFN IDENTIFYUSER PASSWORD)(* bvm%: "22-Mar-84 14:55")

         (* Supervises a registration database operation.
       Does the initial interaction, applies READFN to the input side of the 
       connection to collect results, and interprets same if necessary)

    (\ENQUIRE name (CONS OP (CONS name itemList))
           READFN IDENTIFYUSER PASSWORD])

(\ENQUIRE
  [LAMBDA (NAME ARGS READFN IDENTIFYUSER PASSWORD)       (* ; "Edited 15-Jun-90 14:27 by jds")

         (* Attempt to accomplish some interaction with a reg.
       server. Implements the Taft/Birrell approach of first trying anybody we're 
       connected to, failing that trying the closest reg.
       server we can find, and only if that fails as well do we get down to basics and 
       actually go thru the lookup procedure to find someone who knows what we need)

    (PROG ((REGISTRY REGROOT)
           RESULT CONN INFO)
      LP  (COND
             ((NOT (SETQ CONN (FINDREGSERVER REGISTRY)))
              (RETURN EC.ALLDOWN)))
          [COND
             (IDENTIFYUSER [COND
                              ((EQ IDENTIFYUSER T)
                               (SETQ INFO (\INTERNAL/GETPASSWORD))
                               (SETQ IDENTIFYUSER (CAR INFO]
                    (COND
                       ((AND (NEQ (fetch (GVCONNECTION GVIDENTIFIED) of CONN)
                                  IDENTIFYUSER)
                             (NOT (EQUAL (fetch (GVCONNECTION GVIDENTIFIED) of CONN)
                                         IDENTIFYUSER)))
                        (COND
                           ([NOT (SETQ RESULT (\PERFORMGVOP CONN
                                                     (LIST \OP.IDENTIFYCALLER (\CHECKNAME 
                                                                                     IDENTIFYUSER)
                                                           (\CHECKKEY (OR PASSWORD (CDR INFO]
                            (BLOCK)
                            (replace (GVCONNECTION GVBUSY) of CONN with NIL)
                            (GO LP))
                           ((SETQ RESULT (SELECTC (fetch HIBYTE of RESULT)
                                             (\RC.BADRNAME EC.BADRNAME)
                                             (\RC.BADPASSWORD 
                                                  EC.BADPASSWORD)
                                             (\RC.ALLDOWN EC.ALLDOWN)
                                             (\RC.DONE NIL)
                                             (SHOULDNT)))
                            (RETURN RESULT))
                           (T (replace (GVCONNECTION GVIDENTIFIED) of CONN with 
                                                                                         IDENTIFYUSER
                                     ]
          (SETQ RESULT (SELECTC (COND
                                   ((SETQ RESULT (\PERFORMGVOP CONN ARGS))
                                                             (* we ignore the name type and 
                                                           return the code part of the return 
                                                           code)
                                    (SETQ GVNAMETYPE (fetch LOBYTE of RESULT))
                                    (SETQ RESULT (fetch HIBYTE of RESULT)))
                                   (T 

         (* The usual causes for this are the stream is not in fact open despite our 
       efforts to insure that it is, or that the other end has gone to sleep and the 
       BSPIOTIMEOUT occurs. If this happens too often, \REG.IOTIMEOUT should be 
       lengthened)

                                      (BLOCK)                (* Let RTP run and clean this guy 
                                                           out)
                                      (replace (GVCONNECTION GVBUSY) of CONN with NIL)
                                      (GO LP)))
                           (\RC.NOCHANGE                     (* For use with timestamps, says 
                                                           entry has not changed, so no values 
                                                           to return)
                                         EC.NOCHANGE)
                           (\RC.DONE (COND
                                        (READFN (APPLY* READFN (fetch (GVCONNECTION GVINSTREAM)
                                                                  of CONN)))
                                        (T T)))
                           (\RC.WRONGSERVER                  (* so we have to do it right after 
                                                           all)
                                (COND
                                   ((NEQ REGISTRY REGROOT)
                                    EC.BADRNAME)
                                   (T (replace (GVCONNECTION GVBUSY) of CONN with NIL)
                                      (SETQ REGISTRY (CONS (CDR NAME)
                                                           'GV))
                                      (GO LP))))
                           (\RC.BADRNAME EC.BADRNAME)
                           (\RC.NOTALLOWED 
                                EC.NOTALLOWED)
                           (\RC.BADPASSWORD 
                                EC.BADPASSWORD)
                           (\RC.ALLDOWN EC.ALLDOWN)
                           RESULT))
          (replace (GVCONNECTION GVBUSY) of CONN with NIL)
          (RETURN RESULT])

(\PERFORMGVOP
  [LAMBDA (CONN ARGS)                                    (* ; "Edited 15-Jun-90 14:27 by jds")
    (CAR (NLSETQ (LET ((STREAM (fetch (GVCONNECTION GVOUTSTREAM) of CONN)))
                      (for e in ARGS do (\SENDITEM STREAM e))
                      (FORCEOUTPUT STREAM)
                      (\RECEIVEWORD (fetch (GVCONNECTION GVINSTREAM) of CONN])

(FINDREGSERVER
  [LAMBDA (REGISTRY ERRORFLG)                            (* ; "Edited 15-Jun-90 14:27 by jds")
                                                             (* Find a registration server for 
                                                           REGISTRY -
                                                           the closest one available)
    (PROG (NEWSOC)
          [COND
             ((NLISTP REGISTRY)
              (SETQ REGISTRY (\UNPACKREG REGISTRY]
          (RETURN (COND
                     [(UNINTERRUPTABLY
                          (for CONN in \GVCONNECTIONS
                             when [AND (NULL (fetch (GVCONNECTION GVBUSY) of CONN))
                                           (OR (EQ REGISTRY REGROOT)
                                               (EQUAL REGISTRY (fetch (GVCONNECTION GVREGISTRY)
                                                                  of CONN]
                             do (replace (GVCONNECTION GVBUSY) of CONN with T)
                                   (RETURN CONN)))]
                     ((SETQ NEWSOC (OPENCLOSESTSOCKET (LOCATESOCKETS REGISTRY ERRORFLG)
                                          \REG.SERVERPOLLINGSOC \REG.SERVERENQUIRYSOC \REG.IOTIMEOUT)
                       )
                      (replace (GVCONNECTION GVREGISTRY) of NEWSOC with REGISTRY)
                      (replace (GVCONNECTION GVBUSY) of NEWSOC with T)
                      (push \GVCONNECTIONS NEWSOC)
                      NEWSOC)
                     (ERRORFLG (ERROR "Couldn't open connection for" REGISTRY])

(LOCATESOCKETS
  [LAMBDA (SITE ERRORFLG)                                (* bvm%: "17-SEP-83 14:15")

         (* get a list of sockets for a SITE -
       a three step process (except for GV.GV) -
       find the members of the site, find the connect sites for each, turn those into 
       sockets)

    (COND
       ((EQUAL SITE REGROOT)                                 (* treat the root -
                                                           "GV.GV" -
                                                           specially)
        (ETHERPORT REGROOTNLSNAME ERRORFLG T))
       (T (bind cn for rName in [CDR (OR (LISTP (GV.READMEMBERS SITE))
                                                     (COND
                                                        (ERRORFLG (ERROR "Not a valid site" SITE]
             join (OR (AND (SETQ cn (STRINGP (GV.READCONNECT rName)))
                               (ETHERPORT cn NIL T))
                          (ETHERPORT rName NIL T)
                          (COND
                             (ERRORFLG (HELP "Can't look up connect name" (CONS rName cn])
)

(ADDTOVAR \GVCONNECTIONS )

(RPAQQ REGROOT (GV . GV))

(RPAQ REGROOTNLSNAME "GrapevineRServer")

(RPAQQ \REG.IOTIMEOUT 30000)
(DECLARE%: DOEVAL@COMPILE DONTCOPY 

(RPAQQ GVPROTOCOLDEFS
       ((CONSTANTS * \GV.OPS)
        (* Grapevine response codes)
        (CONSTANTS * \GV.RESPONSES)
        (* Response codes the user sees)
        (CONSTANTS * \GVU.RESPONSES)
        (GLOBALVARS REGROOT REGROOTNLSNAME \REG.IOTIMEOUT \GVCONNECTIONS)
        (CONSTANTS (\REG.SERVERENQUIRYSOC 40)
               (\REG.SERVERPOLLINGSOC 42))
        (* Constants for calling GV.ISINLIST)
        (CONSTANTS * \GVU.MEMBEROPS)))

(RPAQQ \GV.OPS
       ((\OP.GVEXPAND 1)
        (\OP.READMEMBERS 2)
        (\OP.READOWNERS 3)
        (\OP.READFRIENDS 4)
        (\OP.READENTRY 5)
        (\OP.CHECKSTAMP 6)
        (\OP.READCONNECT 7)
        (\OP.READREMARK 8)
        (\OP.AUTHENTICATE 9)
        (\OP.IDENTIFYCALLER 33)
        (\OP.ISMEMBERDIRECT 40)
        (\OP.ISOWNERDIRECT 41)
        (\OP.ISFRIENDDIRECT 42)
        (\OP.ISMEMBERCLOSURE 43)
        (\OP.ISOWNERCLOSURE 44)
        (\OP.ISFRIENDCLOSURE 45)
        (\OP.ISINLIST 46)
        (\OP.CREATEINDIVIDUAL 12)
        (\OP.DELETEINDIVIDUAL 13)
        (\OP.CREATEGROUP 14)
        (\OP.DELETEGROUP 15)
        (\OP.CHANGEPASSWORD 16)
        (\OP.CHANGECONNECT 17)
        (\OP.CHANGEREMARK 18)
        (\OP.ADDMEMBER 19)
        (\OP.ADDMAILBOX 20)
        (\OP.ADDFORWARD 21)
        (\OP.ADDOWNER 22)
        (\OP.ADDFRIEND 23)
        (\OP.REMOVEMEMBER 24)
        (\OP.REMOVEMAILBOX 25)
        (\OP.REMOVEFORWARD 26)
        (\OP.REMOVEOWNER 27)
        (\OP.REMOVEFRIEND 28)
        (\OP.ADDSELF 29)
        (\OP.REMOVESELF 30)
        (\OP.ADDLISTOFMEMBERS 31)
        (\OP.NEWNAME 32)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \OP.GVEXPAND 1)

(RPAQQ \OP.READMEMBERS 2)

(RPAQQ \OP.READOWNERS 3)

(RPAQQ \OP.READFRIENDS 4)

(RPAQQ \OP.READENTRY 5)

(RPAQQ \OP.CHECKSTAMP 6)

(RPAQQ \OP.READCONNECT 7)

(RPAQQ \OP.READREMARK 8)

(RPAQQ \OP.AUTHENTICATE 9)

(RPAQQ \OP.IDENTIFYCALLER 33)

(RPAQQ \OP.ISMEMBERDIRECT 40)

(RPAQQ \OP.ISOWNERDIRECT 41)

(RPAQQ \OP.ISFRIENDDIRECT 42)

(RPAQQ \OP.ISMEMBERCLOSURE 43)

(RPAQQ \OP.ISOWNERCLOSURE 44)

(RPAQQ \OP.ISFRIENDCLOSURE 45)

(RPAQQ \OP.ISINLIST 46)

(RPAQQ \OP.CREATEINDIVIDUAL 12)

(RPAQQ \OP.DELETEINDIVIDUAL 13)

(RPAQQ \OP.CREATEGROUP 14)

(RPAQQ \OP.DELETEGROUP 15)

(RPAQQ \OP.CHANGEPASSWORD 16)

(RPAQQ \OP.CHANGECONNECT 17)

(RPAQQ \OP.CHANGEREMARK 18)

(RPAQQ \OP.ADDMEMBER 19)

(RPAQQ \OP.ADDMAILBOX 20)

(RPAQQ \OP.ADDFORWARD 21)

(RPAQQ \OP.ADDOWNER 22)

(RPAQQ \OP.ADDFRIEND 23)

(RPAQQ \OP.REMOVEMEMBER 24)

(RPAQQ \OP.REMOVEMAILBOX 25)

(RPAQQ \OP.REMOVEFORWARD 26)

(RPAQQ \OP.REMOVEOWNER 27)

(RPAQQ \OP.REMOVEFRIEND 28)

(RPAQQ \OP.ADDSELF 29)

(RPAQQ \OP.REMOVESELF 30)

(RPAQQ \OP.ADDLISTOFMEMBERS 31)

(RPAQQ \OP.NEWNAME 32)


(CONSTANTS (\OP.GVEXPAND 1)
       (\OP.READMEMBERS 2)
       (\OP.READOWNERS 3)
       (\OP.READFRIENDS 4)
       (\OP.READENTRY 5)
       (\OP.CHECKSTAMP 6)
       (\OP.READCONNECT 7)
       (\OP.READREMARK 8)
       (\OP.AUTHENTICATE 9)
       (\OP.IDENTIFYCALLER 33)
       (\OP.ISMEMBERDIRECT 40)
       (\OP.ISOWNERDIRECT 41)
       (\OP.ISFRIENDDIRECT 42)
       (\OP.ISMEMBERCLOSURE 43)
       (\OP.ISOWNERCLOSURE 44)
       (\OP.ISFRIENDCLOSURE 45)
       (\OP.ISINLIST 46)
       (\OP.CREATEINDIVIDUAL 12)
       (\OP.DELETEINDIVIDUAL 13)
       (\OP.CREATEGROUP 14)
       (\OP.DELETEGROUP 15)
       (\OP.CHANGEPASSWORD 16)
       (\OP.CHANGECONNECT 17)
       (\OP.CHANGEREMARK 18)
       (\OP.ADDMEMBER 19)
       (\OP.ADDMAILBOX 20)
       (\OP.ADDFORWARD 21)
       (\OP.ADDOWNER 22)
       (\OP.ADDFRIEND 23)
       (\OP.REMOVEMEMBER 24)
       (\OP.REMOVEMAILBOX 25)
       (\OP.REMOVEFORWARD 26)
       (\OP.REMOVEOWNER 27)
       (\OP.REMOVEFRIEND 28)
       (\OP.ADDSELF 29)
       (\OP.REMOVESELF 30)
       (\OP.ADDLISTOFMEMBERS 31)
       (\OP.NEWNAME 32))
)



(* Grapevine response codes)


(RPAQQ \GV.RESPONSES
       ((\RC.DONE 0)
        (\RC.NOCHANGE 1)
        (\RC.OUTOFDATE 2)
        (\RC.NOTALLOWED 3)
        (\RC.BADOPERATION 4)
        (\RC.BADPROTOCOL 5)
        (\RC.BADRNAME 6)
        (\RC.BADPASSWORD 7)
        (\RC.WRONGSERVER 8)
        (\RC.ALLDOWN 9)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ \RC.DONE 0)

(RPAQQ \RC.NOCHANGE 1)

(RPAQQ \RC.OUTOFDATE 2)

(RPAQQ \RC.NOTALLOWED 3)

(RPAQQ \RC.BADOPERATION 4)

(RPAQQ \RC.BADPROTOCOL 5)

(RPAQQ \RC.BADRNAME 6)

(RPAQQ \RC.BADPASSWORD 7)

(RPAQQ \RC.WRONGSERVER 8)

(RPAQQ \RC.ALLDOWN 9)


(CONSTANTS (\RC.DONE 0)
       (\RC.NOCHANGE 1)
       (\RC.OUTOFDATE 2)
       (\RC.NOTALLOWED 3)
       (\RC.BADOPERATION 4)
       (\RC.BADPROTOCOL 5)
       (\RC.BADRNAME 6)
       (\RC.BADPASSWORD 7)
       (\RC.WRONGSERVER 8)
       (\RC.ALLDOWN 9))
)



(* Response codes the user sees)


(RPAQQ \GVU.RESPONSES
       ((EC.STREAMLOST 'StreamLost)
        (EC.ALLDOWN 'AllDown)
        (EC.NOCHANGE 'NoChange)
        (EC.BADRNAME 'BadRName)
        (EC.BADPASSWORD 'BadPassword)
        (EC.NOTALLOWED 'NotAllowed)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ EC.STREAMLOST StreamLost)

(RPAQQ EC.ALLDOWN AllDown)

(RPAQQ EC.NOCHANGE NoChange)

(RPAQQ EC.BADRNAME BadRName)

(RPAQQ EC.BADPASSWORD BadPassword)

(RPAQQ EC.NOTALLOWED NotAllowed)


(CONSTANTS (EC.STREAMLOST 'StreamLost)
       (EC.ALLDOWN 'AllDown)
       (EC.NOCHANGE 'NoChange)
       (EC.BADRNAME 'BadRName)
       (EC.BADPASSWORD 'BadPassword)
       (EC.NOTALLOWED 'NotAllowed))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS REGROOT REGROOTNLSNAME \REG.IOTIMEOUT \GVCONNECTIONS)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ \REG.SERVERENQUIRYSOC 40)

(RPAQQ \REG.SERVERPOLLINGSOC 42)


(CONSTANTS (\REG.SERVERENQUIRYSOC 40)
       (\REG.SERVERPOLLINGSOC 42))
)



(* Constants for calling GV.ISINLIST)


(RPAQQ \GVU.MEMBEROPS ((OP.ITSELF 0)
                           (OP.ITSREGISTRY 1)
                           (OP.MEMBERS 0)
                           (OP.OWNERS 1)
                           (OP.FRIENDS 2)
                           (OP.DIRECT 0)
                           (OP.CLOSURE 1)
                           (OP.UPARROW 2)))
(DECLARE%: EVAL@COMPILE 

(RPAQQ OP.ITSELF 0)

(RPAQQ OP.ITSREGISTRY 1)

(RPAQQ OP.MEMBERS 0)

(RPAQQ OP.OWNERS 1)

(RPAQQ OP.FRIENDS 2)

(RPAQQ OP.DIRECT 0)

(RPAQQ OP.CLOSURE 1)

(RPAQQ OP.UPARROW 2)


(CONSTANTS (OP.ITSELF 0)
       (OP.ITSREGISTRY 1)
       (OP.MEMBERS 0)
       (OP.OWNERS 1)
       (OP.FRIENDS 2)
       (OP.DIRECT 0)
       (OP.CLOSURE 1)
       (OP.UPARROW 2))
)
)



(* Making server connections)

(DEFINEQ

(OPENCLOSESTSOCKET
  [LAMBDA (PORTLIST POLLSOC CONNSOC TIMEOUT)             (* bvm%: "19-Jul-85 12:42")

         (* Open a BSP connection with the "closest" respondant on portList.
       EchoMe polling to determine responsiveness is to pollSoc, connection will go to 
       connSoc. We poll in order from nearest to farest by hop order, use broadcast on 
       local net if appropriate, and hope not to engage too many folks before the real 
       thing comes along. The basic structure of this is owed to Taft)

    (RESETLST
        [PROG ((MYNET (\LOCALPUPNETNUMBER))
               (BETWEENPROBE (SETUPTIMER 0))
               (PROBECOUNT 1)
               LOCALPORTS ALLPORTS SOC CNTIME REMAININGPORTS PORT VAL PUP)
              [for PORT in PORTLIST do (COND
                                                      ((AND POLLSOC (EQ (fetch PUPNET#
                                                                           of (CAR PORT))
                                                                        MYNET))
                                                       (push LOCALPORTS PORT))
                                                      (T (push ALLPORTS PORT]
              [COND
                 (ALLPORTS (SETQ ALLPORTS (SORT.PUPHOSTS.BY.DISTANCE ALLPORTS]
              (COND
                 [LOCALPORTS 

         (* if there is more than one local host on the list, remove them and add a 
       broadcast port for cheaper poll)

                        (SETQ ALLPORTS (COND
                                          ((CDR LOCALPORTS)
                                           (CONS (LIST (create PUPADDRESS
                                                              PUPNET# _ MYNET
                                                              PUPHOST# _ 0))
                                                 ALLPORTS))
                                          (T (APPEND LOCALPORTS ALLPORTS]
                 ((NULL ALLPORTS)
                  (RETURN)))
              [RESETSAVE NIL (LIST 'CLOSEPUPSOCKET (SETQ SOC (OPENPUPSOCKET]
              (SETQ CNTIME (SETUPTIMER \CONNECTTIMEOUT))
              (SETQ REMAININGPORTS ALLPORTS)
              (RETURN (do [COND
                                 ((TIMEREXPIRED? BETWEENPROBE)
                                  [COND
                                     ((EQ (SETQ PROBECOUNT (SUB1 PROBECOUNT))
                                          0)
                                      (SETQ PORT (CAR REMAININGPORTS))
                                      (SETQ PROBECOUNT (COND
                                                          ((EQ (fetch PUPNET# of (CAR PORT))
                                                               MYNET)
                                                           1)
                                                          (T (* Try twice for hosts not on local 
                                                           net)
                                                             2)))
                                      (SETQ REMAININGPORTS (OR (CDR REMAININGPORTS)
                                                               ALLPORTS]
                                  (SETQ PUP (ALLOCATE.PUP))
                                  (SETUPPUP PUP (CAR PORT)
                                         (OR POLLSOC (CDR PORT)
                                             \DEFAULTPOLLINGSOC)
                                         \PT.ECHOME NIL SOC 'FREE)
                                  (SENDPUP SOC PUP)
                                  (SETQ BETWEENPROBE (SETUPTIMER \BETWEENPROBEDELAY BETWEENPROBE]
                             (BLOCK)
                             (COND
                                ((AND (SETQ PUP (GETPUP SOC))
                                      (EQ (fetch PUPTYPE of PUP)
                                          \PT.IAMECHO)
                                      (OR (NEQ (fetch PUPSOURCENET of PUP)
                                               MYNET)
                                          (ASSOC (fetch PUPSOURCE of PUP)
                                                 LOCALPORTS))
                                      (SETQ VAL (\OPENGVCONNECTION (CONS (fetch PUPSOURCE
                                                                                of PUP)
                                                                             (OR CONNSOC
                                                                                 (fetch 
                                                                                      PUPSOURCESOCKET
                                                                                    of PUP)))
                                                       TIMEOUT)))

         (* We got back an echo and succeeded in opening a connection.
       ASSOC test assures that we don't pay attention to broadcast replies from hosts 
       that we weren't planning to talk to in the first place)

                                 (RETURN VAL))) repeatuntil (TIMEREXPIRED? CNTIME])])

(\OPENGVCONNECTION
  [LAMBDA (FRNSOCKET TIMEOUT ERRORHANDLER FAILURESTRING) (* bvm%: " 4-Feb-86 12:38")
    (LET ((INSTREAM (OPENBSPSTREAM FRNSOCKET NIL ERRORHANDLER TIMEOUT NIL (FUNCTION \GV.WHENCLOSED)
                           FAILURESTRING)))
         (AND INSTREAM (COND
                          ((STREAMP INSTREAM)
                           (create GVCONNECTION
                                  GVINSTREAM _ INSTREAM
                                  GVOUTSTREAM _ (BSPOUTPUTSTREAM INSTREAM)))
                          (T                                 (* Failed)
                             INSTREAM])

(GV.KILLSOCKET
  [LAMBDA (SOCKET TIMEOUT)                               (* ; "Edited 15-Jun-90 14:27 by jds")
    (CLOSEBSPSTREAM (fetch (GVCONNECTION GVINSTREAM) of SOCKET)
           TIMEOUT)
    (BLOCK])

(\GV.WHENCLOSED
  [LAMBDA (BSPSTREAM)                                    (* ; "Edited 15-Jun-90 14:27 by jds")
                                                             (* Called when BSPSTREAM is killed)
    (for CONN in \GVCONNECTIONS when (EQ (fetch (GVCONNECTION GVINSTREAM)
                                                        of CONN)
                                                     BSPSTREAM)
       do (replace (GVCONNECTION GVIDENTIFIED) of CONN with NIL)
             (SETQ \GVCONNECTIONS (DREMOVE CONN \GVCONNECTIONS])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(RECORD GVCONNECTION (GVINSTREAM GVOUTSTREAM GVBUSY GVREGISTRY GVHOPS GVIDENTIFIED))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \DEFAULTPOLLINGSOC 5)


(CONSTANTS (\DEFAULTPOLLINGSOC 5))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \BETWEENPROBEDELAY \CONNECTTIMEOUT)
)
)

(RPAQQ \BETWEENPROBEDELAY 1000)

(RPAQQ \CONNECTTIMEOUT 30000)



(* Checking arguments)

(DEFINEQ

(\CHECKNAME
  [LAMBDA (NAME)                                         (* bvm%: "17-SEP-83 14:37")
    [COND
       ((NLISTP NAME)
        (SETQ NAME (\UNPACKREG (OR NAME (\NONAMEERR]
    (COND
       ((ILESSP (IPLUS (NCHARS (CAR NAME))
                       (NCHARS (CDR NAME)))
               \MAXGVSTRING)                                 (* less than because the dot takes 1 
                                                           more)
        NAME)
       (T (ERROR "name too long - must be < 65 chars" NAME])

(\CHECKSTRING
  [LAMBDA (STRING)                                       (* Beau " 7-SEP-82 13:43")
    (SELECTQ (TYPENAME STRING)
        (STRINGP)
        (LISTP (COND
                  [(AND (CAR STRING)
                        (LITATOM (CAR STRING))
                        (CDR STRING)
                        (LITATOM (CDR STRING)))
                   (SETQ STRING (CONCAT (CAR STRING)
                                       '%.
                                       (CDR STRING]
                  (T (ERROR "bad string arg" STRING))))
        (LITATOM (SETQ STRING (MKSTRING STRING)))
        (ERROR "bad string arg" STRING))
    (COND
       ((IGREATERP (NCHARS STRING)
               \MAXGVSTRING)
        (ERROR "string too long" STRING))
       (T STRING])

(\NONAMEERR
  [LAMBDA NIL                                            (* ht%: "13-JAN-82 12:05")
    (ERROR "must have name for GV user op"])

(\UNPACKREG
  [LAMBDA (REG)                                          (* bvm%: "20-Jul-85 17:11")
    (LET ((PPOS (STRPOS "." REG)))
         (COND
            [PPOS (CONS (SUBATOM REG 1 (SUB1 PPOS))
                        (SUBATOM REG (ADD1 PPOS]
            (T (CONS (MKATOM REG)
                     DEFAULTREGISTRY])
)

(RPAQ? DEFAULTREGISTRY )
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DEFAULTREGISTRY)
)



(* GVKEY)

(DEFINEQ

(\CHECKKEY
  [LAMBDA (KEY)                                          (* bvm%: "17-SEP-83 14:18")
    (COND
       ((KEYP KEY)
        KEY)
       (T (GV.MAKEKEY KEY])

(GV.MAKEKEY
  [LAMBDA (STRING ISCLEAR)                               (* bvm%: "19-Jul-85 16:42")
                                                             (* As per section 2 of the Grapevine 
                                                           Interface document)
    (for I from 0 bind J C (KEY _ (CREATEKEY)) while (SETQ C (NTHCHARCODE
                                                                              STRING
                                                                              (ADD1 I)))
       do (SETKEYBYTE KEY (SETQ J (IMOD I 8))
                     (LOGXOR (GETKEYBYTE KEY J)
                            (LOGAND (LLSH (PROGN (OR ISCLEAR (SETQ C (\DECRYPT.PWD.CHAR C)))
                                                 (COND
                                                    [(AND (IGEQ C (CHARCODE A))
                                                          (ILEQ C (CHARCODE Z)))
                                                             (* Coerce alphabetics to lowercase)
                                                     (IPLUS C (IDIFFERENCE (CHARCODE a)
                                                                     (CHARCODE A]
                                                    (T C)))
                                          1)
                                   255))) finally (RETURN KEY])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(DATATYPE GVKEY ((GVKEY0 8 BYTE)))
)

(/DECLAREDATATYPE 'GVKEY '(BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE)
       '((GVKEY 0 (BITS . 7))
         (GVKEY 0 (BITS . 135))
         (GVKEY 1 (BITS . 7))
         (GVKEY 1 (BITS . 135))
         (GVKEY 2 (BITS . 7))
         (GVKEY 2 (BITS . 135))
         (GVKEY 3 (BITS . 7))
         (GVKEY 3 (BITS . 135)))
       '4)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \#BYTES.GVKEY 8)


(CONSTANTS \#BYTES.GVKEY)
)

(DECLARE%: EVAL@COMPILE 

(PUTPROPS KEYP MACRO ((X)
                              (type? GVKEY X)))

(PUTPROPS CREATEKEY MACRO (NIL (create GVKEY)))

(PUTPROPS GETKEYBYTE MACRO (= . \GETBASEBYTE))

(PUTPROPS SETKEYBYTE MACRO (= . \PUTBASEBYTE))
)
)

(/DECLAREDATATYPE 'GVKEY '(BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE)
       '((GVKEY 0 (BITS . 7))
         (GVKEY 0 (BITS . 135))
         (GVKEY 1 (BITS . 7))
         (GVKEY 1 (BITS . 135))
         (GVKEY 2 (BITS . 7))
         (GVKEY 2 (BITS . 135))
         (GVKEY 3 (BITS . 7))
         (GVKEY 3 (BITS . 135)))
       '4)



(* TIMESTAMP)

(DECLARE%: DOEVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE

(DATATYPE TIMESTAMP ((TIMEHOST BITS 16)
                         (TIMETIMELO WORD)                   (* Mesa numbers backwards)
                         (TIMETIMEHI WORD))
                        [ACCESSFNS TIMESTAMP ((TIMETIME (\MAKENUMBER (fetch (TIMESTAMP TIMETIMEHI
                                                                                       ) of
                                                                                         DATUM)
                                                               (fetch (TIMESTAMP TIMETIMELO)
                                                                  of DATUM])
)

(/DECLAREDATATYPE 'TIMESTAMP '((BITS 16)
                               WORD WORD)
       '((TIMESTAMP 0 (BITS . 15))
         (TIMESTAMP 1 (BITS . 15))
         (TIMESTAMP 2 (BITS . 15)))
       '4)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \#BYTES.TIMESTAMP 6)


(CONSTANTS \#BYTES.TIMESTAMP)
)
)

(/DECLAREDATATYPE 'TIMESTAMP '((BITS 16)
                               WORD WORD)
       '((TIMESTAMP 0 (BITS . 15))
         (TIMESTAMP 1 (BITS . 15))
         (TIMESTAMP 2 (BITS . 15)))
       '4)
(DEFINEQ

(\TIMESTAMP.DEFPRINT
  [LAMBDA (STAMP STREAM)                                 (* bvm%: "21-May-86 10:44")
    (.SPACECHECK. STREAM 6)
    (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))
    (printout STREAM "<GV: " (PORTSTRING (fetch (TIMESTAMP TIMEHOST) of STAMP))
           " at "
           (GDATE (ALTO.TO.LISP.DATE (fetch (TIMESTAMP TIMETIME) of STAMP))
                  (DATEFORMAT NO.SECONDS))
           ">")
    T])

(\CHECKSTAMP
  [LAMBDA (STAMP)                                        (* bvm%: "19-Jul-85 16:54")
    (COND
       (STAMP (\DTEST STAMP 'TIMESTAMP))
       (T (create TIMESTAMP])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(DEFPRINT 'TIMESTAMP '\TIMESTAMP.DEFPRINT)
)



(* I/O primitives)

(DEFINEQ

(\SENDITEM
  [LAMBDA (OUTSTREAM ITEM)                               (* bvm%: "20-Jul-85 17:30")

         (* send out ITEM as determined by its type as per the specs in section 4.0 of 
       the Grapevine Interface document)

    (COND
       ((FIXP ITEM)
        (\SENDWORD OUTSTREAM ITEM))
       [(OR (LITATOM ITEM)
            (STRINGP ITEM))
        (COND
           (ITEM (\SENDSTRING OUTSTREAM ITEM))
           (T                                                (* not a string at all but an empty 
                                                           string list)
              (\SENDWORD OUTSTREAM 0]
       ((KEYP ITEM)
        (\BOUTS OUTSTREAM ITEM 0 \#BYTES.GVKEY))
       ((type? TIMESTAMP ITEM)
        (\BOUTS OUTSTREAM ITEM 0 \#BYTES.TIMESTAMP))
       [(LISTP ITEM)                                         (* may be a name pair, a string 
                                                           list, or a byte kludge)
        (COND
           [(LITATOM (CDR ITEM))                             (* an RName -
                                                           cons pair of two atoms)
            (LET [(length (IPLUS 1 (NCHARS (CAR ITEM))
                                 (NCHARS (CDR ITEM]
                 (\SENDWORD OUTSTREAM length)
                 (\SENDWORD OUTSTREAM 0)
                 (PRIN3 (CAR ITEM)
                        OUTSTREAM)
                 (BOUT OUTSTREAM (CHARCODE %.))
                 (PRIN3 (CDR ITEM)
                        OUTSTREAM)
                 (COND
                    ((ODDP length)                           (* padding needed)
                     (BOUT OUTSTREAM 0]
           [(EQ (CAR ITEM)
                \3BYTEKLUDGEKEY)

         (* somewhat miss-named now, this gives a way of sending small numbers as bytes 
       instead of words)

            (for b in (CDR ITEM) do (BOUT OUTSTREAM (LOGAND b 255]
           (T                                                (* string list)
              [\SENDWORD OUTSTREAM (for e in ITEM sum (IPLUS 2 (FOLDHI (NCHARS e)
                                                                                  BYTESPERWORD]
              (for e in ITEM do (\SENDSTRING OUTSTREAM e]
       (T (SHOULDNT])

(\SENDSTRING
  [LAMBDA (STREAM STRING)                                (* bvm%: "19-Jul-85 16:55")
    (PROG ((L (NCHARS STRING)))
          (COND
             ((IGREATERP L \MAXGVSTRING)
              (ERROR "string too long" STRING)
              (RETURN)))
          (\SENDWORD STREAM L)
          (\SENDWORD STREAM \MAXGVSTRING)                    (* This word is ignored)
          (PRIN3 STRING STREAM)
          (COND
             ((ODDP L)                                       (* pad)
              (BOUT STREAM 0])
)
(DEFINEQ

(\RECEIVEBOOL
  [LAMBDA (STREAM)                                       (* bvm%: "11-MAY-83 14:51")
    (SELECTQ (BIN STREAM)
        (1 T)
        (0 NIL)
        (SHOULDNT])

(\RECEIVECLIST
  [LAMBDA (STREAM)                                       (* bvm%: "11-MAY-83 14:57")
                                                             (* receive a list of components)
    (\RECEIVESTAMP STREAM T)
    (to (\RECEIVEWORD STREAM) collect (\RECEIVECOMPONENT STREAM])

(\RECEIVECOMPONENT
  [LAMBDA (STREAM)                                       (* bvm%: "11-MAY-83 14:57")
                                                             (* receive a component -
                                                           just a list of words)
    (to (\RECEIVEWORD STREAM) collect (\RECEIVEWORD STREAM])

(\RECEIVERLIST
  [LAMBDA (INSTREAM)                                     (* bvm%: "11-MAY-83 15:58")
                                                             (* receive a list of RNames -
                                                           prefix the result with the time 
                                                           STAMP)
    (bind STRLEN (STAMP _ (\RECEIVESTAMP INSTREAM))
           (NWORDS _ (\RECEIVEWORD INSTREAM)) while (IGREATERP NWORDS 0)
       collect (PROG1 (\RECEIVESTRING INSTREAM (SETQ STRLEN (\RECEIVEWORD INSTREAM)))
                                                             (* mind the possible odd length, and 
                                                           add 2 NWORDS for STRLEN and max)
                       (SETQ NWORDS (IDIFFERENCE NWORDS (IPLUS (FOLDHI STRLEN BYTESPERWORD)
                                                               2))))
       finally (RETURN (CONS STAMP $$VAL])

(\RECEIVERNAME
  [LAMBDA (INSTREAM)                                     (* bvm%: "11-MAY-83 15:59")
    (\RECEIVESTRING INSTREAM (\RECEIVEWORD INSTREAM])

(\RECEIVESTAMP
  [LAMBDA (STREAM OLDSTAMP)                              (* bvm%: "20-Jul-85 17:16")
    (COND
       ((EQ OLDSTAMP T)
        (RPTQ \#BYTES.TIMESTAMP (BIN STREAM))
        T)
       (T [COND
             ((NOT (type? TIMESTAMP OLDSTAMP))
              (SETQ OLDSTAMP (create TIMESTAMP]
          (\BINS STREAM OLDSTAMP 0 \#BYTES.TIMESTAMP)))
    OLDSTAMP])

(\RECEIVESTRING
  [LAMBDA (STREAM LENGTH)                                (* bvm%: "21-May-86 10:45")
    (\SKIPWORD STREAM)                                       (* ignore maxLength)
    (LET ((STRING (ALLOCSTRING LENGTH)))
         (\BINS STREAM (fetch (STRINGP BASE) of STRING)
                (fetch (STRINGP OFFST) of STRING)
                LENGTH)
         (COND
            ((ODDP LENGTH)
             (BIN STREAM)))
         STRING])
)

(RPAQQ \3BYTEKLUDGEKEY $$3byte$$)
(DECLARE%: DOEVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \RECEIVEWORD MACRO (= . \WIN))

(PUTPROPS \SKIPWORD MACRO (OPENLAMBDA (STREAM)
                                         (PROGN (BIN STREAM)
                                                (BIN STREAM))))

(PUTPROPS \SENDWORD MACRO (= . \WOUT))
)

(DECLARE%: EVAL@COMPILE 

(RPAQQ \MAXGVSTRING 64)


(CONSTANTS (\MAXGVSTRING 64))
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \3BYTEKLUDGEKEY)
)
)
(DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY 

(SELECTQ (COMPILEMODE)
    (D (FILESLOAD (LOADCOMP)
              PUP BSP))
    (PDP-10 (FILESLOAD (LOADCOMP)
                   PUP10 BSPAUX))
    NIL)
)
(PUTPROPS GRAPEVINE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3957 7826 (GV.AUTHENTICATE 3967 . 4171) (GV.CHECKSTAMP 4173 . 4417) (GV.EXPAND 4419 . 
4802) (GV.IDENTIFYCALLER 4804 . 5012) (GV.IDENTIFYME 5014 . 5443) (GV.ISINLIST 5445 . 5838) (
GV.ISMEMBERCLOSURE 5840 . 6098) (GV.ISMEMBERDIRECT 6100 . 6356) (GV.READCONNECT 6358 . 6574) (
GV.READENTRY 6576 . 6830) (GV.READFRIENDS 6832 . 7090) (GV.READMEMBERS 7092 . 7350) (GV.READOWNERS 
7352 . 7608) (GV.READREMARK 7610 . 7824)) (7875 14013 (GV.ADDFORWARD 7885 . 8160) (GV.ADDFRIEND 8162
 . 8436) (GV.ADDLISTOFMEMBERS 8438 . 9292) (GV.ADDMAILBOX 9294 . 9569) (GV.ADDMEMBER 9571 . 9849) (
GV.ADDOWNER 9851 . 10122) (GV.CHANGECONNECT 10124 . 10788) (GV.CHANGEPASSWORD 10790 . 11067) (
GV.CHANGEREMARK 11069 . 11348) (GV.CREATEGROUP 11350 . 11576) (GV.CREATEINDIVIDUAL 11578 . 11859) (
GV.DELETEGROUP 11861 . 12087) (GV.DELETEINDIVIDUAL 12089 . 12325) (GV.NEWNAME 12327 . 12598) (
GV.REMOVEFORWARD 12600 . 12881) (GV.REMOVEFRIEND 12883 . 13163) (GV.REMOVEMAILBOX 13165 . 13446) (
GV.REMOVEMEMBER 13448 . 13732) (GV.REMOVEOWNER 13734 . 14011)) (14049 23102 (\GVOP 14059 . 14480) (
\ENQUIRE 14482 . 19829) (\PERFORMGVOP 19831 . 20243) (FINDREGSERVER 20245 . 21933) (LOCATESOCKETS 
21935 . 23100)) (29964 36668 (OPENCLOSESTSOCKET 29974 . 35207) (\OPENGVCONNECTION 35209 . 35844) (
GV.KILLSOCKET 35846 . 36072) (\GV.WHENCLOSED 36074 . 36666)) (37112 38937 (\CHECKNAME 37122 . 37667) (
\CHECKSTRING 37669 . 38447) (\NONAMEERR 38449 . 38601) (\UNPACKREG 38603 . 38935)) (39053 40657 (
\CHECKKEY 39063 . 39244) (GV.MAKEKEY 39246 . 40655)) (43027 43717 (\TIMESTAMP.DEFPRINT 43037 . 43519) 
(\CHECKSTAMP 43521 . 43715)) (43824 46710 (\SENDITEM 43834 . 46163) (\SENDSTRING 46165 . 46708)) (
46711 49644 (\RECEIVEBOOL 46721 . 46907) (\RECEIVECLIST 46909 . 47229) (\RECEIVECOMPONENT 47231 . 
47590) (\RECEIVERLIST 47592 . 48602) (\RECEIVERNAME 48604 . 48773) (\RECEIVESTAMP 48775 . 49167) (
\RECEIVESTRING 49169 . 49642)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/LARGESKETCHPATCH b/internal/library/OBSOLETE/LARGESKETCHPATCH
new file mode 100644
index 00000000..efe2f726
--- /dev/null
+++ b/internal/library/OBSOLETE/LARGESKETCHPATCH
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 17:09:55" 
|{DSK}<usr>local>lde>lispcore>internal>library>LARGESKETCHPATCH.;2| 3370   

      |changes| |to:|  (VARS LARGESKETCHPATCHCOMS)

      |previous| |date:| "27-Feb-87 18:22:14" 
|{DSK}<usr>local>lde>lispcore>internal>library>LARGESKETCHPATCH.;1|)


; Copyright (c) 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT LARGESKETCHPATCHCOMS)

(RPAQQ LARGESKETCHPATCHCOMS ((FNS SKIO.IMAGEBOXFN \\SKIO.IN.TOO.SMALL.TEDITP)))
(DEFINEQ

(SKIO.IMAGEBOXFN
  (LAMBDA (IMAGEOBJ STREAM)                                  (* \; "Edited 27-Feb-87 18:04 by rrb")
                                                             (* |size| |function| |for| \a |sketch| 
                                                             |image| |object.|)
    (PROG ((SKOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))
           SKREG SKW SKH SCALEFACTOR)
          
          (* |determine| |the| |scale| |between| |the| |sketch| |specs| |and| |the| 
          |stream.|)

          (SETQ SCALEFACTOR (QUOTIENT (|fetch| (SKETCHIMAGEOBJ SKIO.SCALE) |of| SKOBJ)
                                   (DSPSCALE NIL STREAM)))
          (SETQ SKW (FIXR (FQUOTIENT (|fetch| (REGION WIDTH) |of| (SETQ SKREG (|fetch| (
                                                                                       SKETCHIMAGEOBJ
                                                                                        SKIO.REGION)
                                                                                 |of| SKOBJ)))
                                 SCALEFACTOR)))
          (SETQ SKH (FIXR (FQUOTIENT (|fetch| (REGION HEIGHT) |of| SKREG)
                                 SCALEFACTOR)))
          (RETURN (COND
                     ((\\SKIO.IN.TOO.SMALL.TEDITP STREAM SKH)
          
          (* |special| |check| |for| |displaying| |in| \a |Tedit| |window| |that| |is| 
          |less| |than| |the| |height| |of| |the| |sketch.|
          |leave| |enough| |height| |for| \a |few| |lines| |of| |text| |too.|)

                      (|create| IMAGEBOX
                             XSIZE _ SKW
                             YSIZE _ (IMAX 12 (DIFFERENCE (|fetch| (REGION HEIGHT)
                                                             |of| (DSPCLIPPINGREGION NIL STREAM))
                                                     24))
                             YDESC _ 0
                             XKERN _ 0))
                     (T (|create| IMAGEBOX
                               XSIZE _ SKW
                               YSIZE _ SKH
                               YDESC _ 0
                               XKERN _ 0)))))))

(\\SKIO.IN.TOO.SMALL.TEDITP
  (LAMBDA (STREAM HEIGHT)                                    (* \; "Edited 27-Feb-87 18:19 by rrb")
          
          (* |is| |this| |stream| \a TEDIT |window| |that| |is| |smaller| |than| 
          |height?|)

    (AND (DISPLAYSTREAMP STREAM)
         (WINDOWPROP (WFROMDS STREAM)
                'TEXTOBJ)
         (GREATERP HEIGHT (|fetch| (REGION HEIGHT) |of| (DSPCLIPPINGREGION NIL STREAM))))))
)
(PUTPROPS LARGESKETCHPATCH COPYRIGHT ("Venue & Xerox Corporation" 1987 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (548 3269 (SKIO.IMAGEBOXFN 558 . 2806) (\\SKIO.IN.TOO.SMALL.TEDITP 2808 . 3267)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/LFHACKS b/internal/library/OBSOLETE/LFHACKS
new file mode 100644
index 00000000..ba7342f6
--- /dev/null
+++ b/internal/library/OBSOLETE/LFHACKS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(filecreated " 4-Jun-87 18:33:02" {eris}<daniels>lisp>lfhacks.\;14 29149  

      |changes| |to:|  (functions determine-system-volume chase-boot-links get-boot-pointer pda-to-vp 
                              vol-num-containing-page vol-index-containing-page 
                              determine-boot-file-runs-using-pointers print-runs-attractively 
                              read-bad-page-table make-page-bad unmake-page-bad determine-file-runs 
                              vp-to-da da-to-vp show-vmem-run-table default-bft fetch-long-cardinal 
                              bootfile-fd write-pv-root-page max-bad-pages write-bad-page-table 
                              bad-page-count list-from-bpt bpt-ref list-bad-pages)
                       (vars lfhackscoms)
                       (variables bpt bft-pilot-boot-file bft-germ bft-emulator-microcode 
                              bft-diagnostic-microcode +boot-file-types+)
                       (setfs bad-page-count bpt-ref)
                       (commands "EC")
                       (structures file-run)
                       (records |PilotDiskAddress| bad-page-table bpt-entry)

      |previous| |date:| " 3-Jun-87 18:31:15" {eris}<daniels>lisp>lfhacks.\;11)


; Copyright (c) 1987 by Xerox Corporation.  All rights reserved.

(prettycomprint lfhackscoms)

(rpaqq lfhackscoms ((coms (functions read-label)
                          (variables bpt-label pv-root-page-label))
                    (coms (variables +boot-file-types+ bft-diagnostic-microcode 
                                 bft-emulator-microcode bft-germ bft-pilot-boot-file)
                          (declare\: eval@compile eval@load dontcopy (records |PilotDiskAddress|))
                          (functions vol-num-containing-page get-boot-pointer write-pv-root-page 
                                 bootfile-fd default-bft determine-system-volume fetch-long-cardinal 
                                 filedesc-from-name first-volume-page vp-to-da da-to-vp pda-to-vp))
                    (coms (declare\: eval@compile eval@load dontcopy (records bad-page-table 
                                                                            bpt-entry))
                          (functions read-bad-page-table)
                          (variables bpt)
                          (functions bad-page-count bpt-ref list-bad-pages list-from-bpt 
                                 make-page-bad max-bad-pages unmake-page-bad write-bad-page-table)
                          (setfs bad-page-count bpt-ref))
                    (coms (structures file-run)
                          (functions determine-file-runs show-vmem-run-table check-pages-free 
                                 print-runs-attractively)
                          (functions chase-boot-links determine-boot-file-runs-using-pointers))
                    (commands "EC")
                    (variables dsktw)
                    (advice |\\DoveDisk.HandleMajorError| |\\DoveDisk.TryRecalibrate|
                           (\\dove.xferdisk :in \\dldisk.execute))
                    (prop filetype lfhacks)))

(cl:defun read-label (pv-page) (let ((label (create |Label|)))
                                    (|\\PFTransferPage| pv-page (ncreate 'vmempagep)
                                           'vrr label 1)
                                    label))


(cl:defparameter bpt-label (read-label 1) )


(cl:defparameter pv-root-page-label (read-label 0) )


(cl:defconstant +boot-file-types+ '((bft-diagnostic-microcode 0)
                                    (bft-emulator-microcode 1)
                                    (bft-germ 2)
                                    (bft-pilot-boot-file 3)) )


(cl:defconstant bft-diagnostic-microcode 0)


(cl:defconstant bft-emulator-microcode 1)


(cl:defconstant bft-germ 2)


(cl:defconstant bft-pilot-boot-file 3)

(declare\: eval@compile eval@load dontcopy 
(declare\: eval@compile

(blockrecord |PilotDiskAddress| ((head byte)
                                 (sector byte)
                                 (cylinder word)))
)
)

(cl:defun vol-num-containing-page (physical-page-number)
   (for vol-num from 0 to (sub1 (|fetch| (|PhysicalVolumeDescriptor| |subVolumeCount|) |of| 
                                                                                   |\\PhysVolumePage|
                                       ))
      do (let ((sv-desc (mesaelt (fetch (|PhysicalVolumeDescriptor| |subVolumes|) of 
                                                                                   |\\PhysVolumePage|
                                        )
                               |SubVolumeArray| vol-num)))
              (cl:when (and (igeq physical-page-number (fetch (|SubVolumeDesc| |pvPage|) of sv-desc))
                            (ilessp physical-page-number (iplus (fetch (|SubVolumeDesc| |pvPage|)
                                                                   of sv-desc)
                                                                (fetch (|SubVolumeDesc| |nPages|)
                                                                   of sv-desc))))
                     (return vol-num)))))


(cl:defun get-boot-pointer (vol-num bft) (cl:if vol-num (mesaelt (fetch (|LogicalVolumeDescriptor|
                                                                         |bootingInfo|)
                                                                    of (elt |\\DFSLogicalVolumes| 
                                                                            vol-num))
                                                               |LVBootFiles| bft)
                                                (mesaelt (fetch (|PhysicalVolumeDescriptor| 
                                                                       |bootingInfo|) of 
                                                                                   |\\PhysVolumePage|
                                                                )
                                                       |PVBootFiles| bft)))


(cl:defun write-pv-root-page nil (|\\PFTransferPage| 0 |\\PhysVolumePage| 'vvw pv-root-page-label 1))


(cl:defun bootfile-fd (&optional volume-num (bft (default-bft)))
   (or volume-num 
          
          (* |;;| "VOLUME-NUM = NIL means use the running sysout.")

       (cl:setf volume-num (determine-system-volume)))
   (create |FileDescriptor|
          |fileID| _ (fetch-long-cardinal (fetch (|DiskFileID| \fid)
                                             of (mesaelt (fetch (|LogicalVolumeDescriptor| 
                                                                       |bootingInfo|)
                                                            of (elt |\\DFSLogicalVolumes| volume-num)
                                                                )
                                                       |LVBootFiles| bft)))
          |volNum| _ volume-num
          |type| _ |tDiagnosticMicrocode|))


(cl:defun default-bft nil (case (machinetype)
                                (dove bft-germ)
                                (cl:otherwise bft-diagnostic-microcode)))


(cl:defun determine-system-volume nil (let* ((first-run (locf (fetch dlvmemfileinfo of \\iocbpage)))
                                             (boot-file-page (da-to-vp (fetch dlvmcyl of first-run)
                                                                    (fetch dlvmhead of first-run)
                                                                    (fetch dlvmsector of first-run)))
                                             )
                                            (vol-num-containing-page boot-file-page)))


(cl:defun fetch-long-cardinal (ptr) (\\makenumber (\\getbase ptr 1)
                                           (\\getbase ptr 0)))


(cl:defun filedesc-from-name (name) (let ((filespec (|\\LFFileSpec| name 'old))
                                          |volNum|)
                                         (create |FileDescriptor|
                                                |fileID| _ (|\\LFReadFileID|
                                                            (|\\LFGetDirectory|
                                                             (setq |volNum|
                                                              (|fetch| (|ExpandedName| volnum)
                                                                 |of| (|fetch| (|DFSFileSpec| 
                                                                                      expandedname)
                                                                         |of| filespec))))
                                                            (|fetch| (|DFSFileSpec| fsdirptr)
                                                               |of| filespec))
                                                |volNum| _ |volNum|
                                                |type| _ |tLispFile|)))


(cl:defun first-volume-page (vol-index) (fetch (|SubVolumeDesc| |pvPage|)
                                           of (mesaelt (fetch (|PhysicalVolumeDescriptor| 
                                                                     |subVolumes|) of 
                                                                                   |\\PhysVolumePage|
                                                              )
                                                     |SubVolumeArray| vol-index)))


(defmacro vp-to-da (vp) `(cl:locally (declare (globalvars \\dldiskshape.sectorspercylinder 
                                                     \\dldiskshape.sectorsperhead))
                                (cl:multiple-value-bind (cylinder rem)
                                       (cl:floor ,vp \\dldiskshape.sectorspercylinder)
                                       (cl:multiple-value-call 'list cylinder (cl:floor rem 
                                                                         \\dldiskshape.sectorsperhead
                                                                                     )))))


(defmacro da-to-vp (cyl hd sec) `(cl:locally (declare (globalvars \\dldiskshape.sectorspercylinder 
                                                             \\dldiskshape.sectorsperhead))
                                        (iplus (itimes ,cyl \\dldiskshape.sectorspercylinder)
                                               (itimes ,hd \\dldiskshape.sectorsperhead)
                                               ,sec)))


(defmacro pda-to-vp (pda) `(let ((pda ,pda))
                                (da-to-vp (fetch (|PilotDiskAddress| cylinder) of pda)
                                       (fetch (|PilotDiskAddress| head) of pda)
                                       (fetch (|PilotDiskAddress| sector) of pda))))

(declare\: eval@compile eval@load dontcopy 
(declare\: eval@compile

(mesaarray bad-page-table ((0 127))
                          bpt-entry)

(mesarecord bpt-entry ((page swappedfixp)))
)
)

(cl:defun read-bad-page-table (&optional (table bpt)) (|\\PFTransferPage| 1 table 'vvr bpt-label 1))


(cl:defparameter bpt (let ((table (ncreate 'vmempagep)))
                          (read-bad-page-table table)
                          table) )


(definline bad-page-count nil (fetch (|PhysicalVolumeDescriptor| |badPageCount|) of 
                                                                                   |\\PhysVolumePage|
                                     ))


(defmacro bpt-ref (index) `(fetch (bpt-entry page) of (mesaelt bpt bad-page-table ,index)))


(cl:defun list-bad-pages (&optional read?) (and read? (read-bad-page-table))
                                           (cl:dotimes (i (bad-page-count)
                                                          (terpri))
                                                  (cl:format t "~D " (bpt-ref i))))


(cl:defun list-from-bpt nil (for i from 0 to (cl:1- (bad-page-count)) collect (bpt-ref i)))


(cl:defun make-page-bad (physical-page-number &optional read?)
   (and read? (read-bad-page-table))
   (let ((bp-list (list-from-bpt)))
        (cond
           ((igeq (cl:list-length bp-list)
                  (max-bad-pages))
            (cl:error "Too many bad pages"))
           ((member physical-page-number bp-list)
            (cl:format *error-output* "~D already marked bad~%" physical-page-number))
           (t (let ((new-bp-list (cl:merge 'list (list physical-page-number)
                                        bp-list
                                        'ilessp)))
                   (for page in new-bp-list as index from 0 do (cl:setf (bpt-ref index)
                                                                      page)
                      finally (cl:setf (bad-page-count)
                                     (cl:list-length new-bp-list))
                            (uninterruptably
                                (write-bad-page-table)
                                (write-pv-root-page))))))))


(defmacro max-bad-pages nil (fetch (|PhysicalVolumeDescriptor| |maxBadPages|) of |\\PhysVolumePage|))


(cl:defun unmake-page-bad (physical-page-number &optional read?)
   (and read? (read-bad-page-table))
   (let ((bp-list (list-from-bpt)))
        (cond
           ((member physical-page-number bp-list)
            (cl:setf bp-list (remove physical-page-number bp-list))
            (for page in bp-list as index from 0 do (cl:setf (bpt-ref index)
                                                           page) finally (cl:setf (bad-page-count)
                                                                                (cl:list-length
                                                                                 bp-list))
                                                                       (uninterruptably
                                                                           (write-bad-page-table)
                                                                           (write-pv-root-page))))
           (t (cl:format *error-output* "~D not in bad page table~%" physical-page-number)))))


(cl:defun write-bad-page-table nil (|\\PFTransferPage| 1 bpt 'vvw bpt-label 1))


(cl:defsetf bad-page-count nil (new-count)
                               `(cl:if (> ,new-count (max-bad-pages))
                                       (cl:error "Too many bad pages")
                                       (replace (|PhysicalVolumeDescriptor| |badPageCount|)
                                          of |\\PhysVolumePage| with ,new-count)))


(cl:defsetf bpt-ref (index) (new-val)
                            `(replace (bpt-entry page)
                                of (\\addbase bpt (iplus ((openlambda (|index|)
                                                                 (or (and (ileq 0 |index|)
                                                                          (ileq |index| 127))
                                                                     (error '|indexOutOfRange|))
                                                                 (itimes 2 (idifference |index| 0)))
                                                          ,index))) with ,new-val))


(cl:defstruct (file-run (:type list)
                        (:conc-name "FR-")) file-page vol-page length)


(cl:defun determine-file-runs (file-desc)
   (let ((file-length (|\\PFFindFileSize| file-desc))
         (page-runs nil)
         (file-page 0))
        (cl:loop (cl:push (make-file-run :file-page file-page :vol-page (|\\PFFindPageAddr| file-desc 
                                                                               file-page)
                                 :length
                                 (difference (fetch (|PageGroup| |nextFilePage|)
                                                of (fetch (|FileDescriptor| pagegroup) of file-desc))
                                        file-page))
                        page-runs)
               (setq file-page (fetch (|PageGroup| |nextFilePage|) of (fetch (|FileDescriptor| 
                                                                                    pagegroup)
                                                                         of file-desc)))
               (cl:when (>= file-page file-length)
                      (return (reverse page-runs))))))


(cl:defun show-vmem-run-table
   nil (let ((linkbase (locf (fetch (iocbpage dlvmemfileinfo) of \\iocbpage))))
            (cl:format t "File Page Numbers  =>  Disk Page Numbers~%")
            (bind (vp _ 0)
                  end-of-run-vp da end-of-run-da run-list
               eachtime (cl:setf da (da-to-vp (fetch (dlvmemrun dlvmcyl) of linkbase)
                                           (fetch (dlvmemrun dlvmhead) of linkbase)
                                           (fetch (dlvmemrun dlvmsector) of linkbase)))
               while (neq 0 (fetch (dlvmemrun dlfirstfilepage) of (fetch (dlvmemrun dlnextrun)
                                                                     of linkbase)))
               do (cl:setf end-of-run-vp (cl:1- (fetch (dlvmemrun dlfirstfilepage)
                                                   of (fetch (dlvmemrun dlnextrun) of linkbase)))
                         end-of-run-da
                         (iplus da (idifference end-of-run-vp vp)))
                  (cl:format t "[~D..~D]  =>  [~D..~D]~A~%" vp end-of-run-vp da end-of-run-da
                         (cond
                            ((some run-list #'(lambda (prev-addr-range)
                                                (and (igeq da (car prev-addr-range))
                                                     (ileq da (cdr prev-addr-range)))))
                             " <= Entirely bogus VMem run!")
                            ((not (eqp (idifference end-of-run-vp vp)
                                       (idifference end-of-run-da da)))
                             " <= VMem run length doesn't match disk run length!")
                            (t "")))
                  (push run-list (cons da end-of-run-da))
                  (cl:setf vp (fetch (dlvmemrun dlfirstfilepage) of (fetch (dlvmemrun dlnextrun)
                                                                       of linkbase))
                         linkbase
                         (fetch (dlvmemrun dlnextrun) of linkbase))
               finally (cl:setf end-of-run-vp (fetch (ifpage |DLLastVmemPage|) of |\\InterfacePage|))
                     (cl:format t "[~D..~D]  =>  [~D..~D]~%" vp end-of-run-vp da
                            (iplus da (idifference end-of-run-vp vp))))))


(cl:defun check-pages-free (vol file-runs &optional (one-at-a-time? t)) 
          
          (* |;;| "Check that the labels for the given pages look good. Doesn't check the VAM yet.")
 (for run in file-runs
    do (with-resource |\\DFSVAMjunkPage| (if one-at-a-time?
                                             then (for vol-page from (fr-vol-page run) as counter
                                                     from 1 to (fr-length run)
                                                     do (proceed-case (|\\PFGetFreePage| vol vol-page 
                                                                             |\\DFSVAMjunkPage| 1)
                                                               (continue nil :report 
                                                                      "Skip this page and continue"))
                                                       )
                                           else (|\\PFGetFreePage| vol (fr-vol-page run)
                                                       |\\DFSVAMjunkPage|
                                                       (fr-length run))))))


(cl:defun print-runs-attractively (file-runs &optional vol-num)
   (let ((offset (cl:if vol-num (first-volume-page vol-num)
                        0)))
        (for run in file-runs first (cl:format t "File Page Numbers  =>  Disk Page Numbers~%")
           do (cl:format t "[~D..~D]  =>  [~D..~D]~%" (fr-file-page run)
                     (cl:1- (+ (fr-file-page run)
                               (fr-length run)))
                     (+ (fr-vol-page run)
                        offset)
                     (cl:1- (+ (fr-vol-page run)
                               offset
                               (fr-length run)))))))


(cl:defun chase-boot-links (fn &key vol-num (bft (default-bft))
                               verbose) 
          
          (* |;;| "runs through the bootfile starting from the appropriate boot pointer, using the LV boot pointer is a particular volume is specified, following the boot links. FN is called on each page with a physical page number, file page number, and file id. If verbose is true, will print something every 100 pages.")
 (let ((boot-pointer (get-boot-pointer vol-num bft)))
      (cl:when (cl:zerop (fetch (|DiskFileID| |da|) of boot-pointer))
             (cl:error "No boot pointer found."))
      (with-resource |label| (bind (correct-id _ (fetch-long-cardinal (fetch (|DiskFileID| \fid)
                                                                         of boot-pointer)))
                                   (last-boot-file-page _ (cl:1- (|\\PFFindFileSize| (bootfile-fd
                                                                                      vol-num bft))))
                                   (vp _ (pda-to-vp (fetch (|DiskFileID| |da|) of boot-pointer)))
                                   (fp _ (cl:1- (fetch (|DiskFileID| |firstPage|) of boot-pointer)))
                                   (buffer _ (ncreate 'vmempagep))
                                   file-id first (cl:when verbose (cl:princ "Processing bootfile" 
                                                                         *error-output*))
                                for page-num from 0
                                do 
          
          (* |;;| "Read next page")

                                   (cl:when (eql (cl:mod fp 100)
                                                 99)
                                          (cl:when verbose (cl:princ "." *error-output*))
                                          (block))
                                   (let ((status (|\\PFTransferPage| vp buffer 'vrr |label| 1)))
                                        (cl:when (not (eq status 'ok))
                                               (cl:cerror "Continue processing the file" 
                                                      "Can't read page ~D: status = ~S" vp status)))
                                   (cl:when (not (eql (cl:1+ fp)
                                                      (fetch (|Label| |filePage|) of |label|)))
                                          (cl:cerror "Continue processing the file" 
                                            "Boot file pages not contiguous: prev = ~D, current = ~D" 
                                                 fp (fetch (|Label| |filePage|) of |label|)))
                                   (cl:when (not (eql (cl:setf file-id (fetch (|Label| |fileID|)
                                                                          of |label|))
                                                      correct-id))
                                          (cl:cerror "Continue processing the file" 
                                              "File id in label (~D) doesn't match boot pointer (~D)" 
                                                 file-id correct-id))
                                   (cl:setf fp (fetch (|Label| |filePage|) of |label|))
                                   (cl:funcall fn vp fp page-num file-id)
                                   (cond
                                      ((and (eql -1 (fetch (|PilotDiskLabel| |BootLinkA|)
                                                       of |label|))
                                            (eql -1 (fetch (|PilotDiskLabel| |BootLinkB|)
                                                       of |label|)))
                                       (cl:when verbose (cl:princ "<boot link all 1's> " 
                                                               *error-output*))
                                       (return))
                                      ((igeq fp last-boot-file-page)
                                       (cl:when verbose (cl:princ "<end of file> " *error-output*))
                                       (return))
                                      ((and (cl:zerop (fetch (|PilotDiskLabel| |BootLinkA|)
                                                         of |label|))
                                            (cl:zerop (fetch (|PilotDiskLabel| |BootLinkB|)
                                                         of |label|)))
          
          (* |;;| "No boot link - continue to next page")

                                       (cl:incf vp))
                                      (t 
          
          (* |;;| "Have a real boot link - jump to new disk address")

                                         (cl:setf vp (pda-to-vp (\\makenumber (fetch (
                                                                                     |PilotDiskLabel|
                                                                                      |BootLinkB|)
                                                                                 of |label|)
                                                                       (fetch (|PilotDiskLabel|
                                                                               |BootLinkA|)
                                                                          of |label|))))
                                         (cl:when verbose (cl:format *error-output* "<Jump to ~D>" vp
                                                                 ))))))
      (cl:when verbose (cl:princ "done." *error-output*)
             (cl:terpri *error-output*))))


(cl:defun determine-boot-file-runs-using-pointers (&rest key-args &key vol-num (bft (default-bft))
                                                         verbose)
   (let ((offset (first-volume-page (vol-num-containing-page (pda-to-vp (fetch (|DiskFileID| |da|)
                                                                           of (get-boot-pointer
                                                                               vol-num bft))))))
         (run-list nil)
         last-vp run)
        (cl:apply 'chase-boot-links
               #'(cl:lambda (vp fp page-num file-id)
                        (declare (ignore page-num file-id))
                        (cl:flet ((new-run (fp vp)
                                         (cl:push (cl:setf run (make-file-run :file-page fp :vol-page
                                                                      (- vp offset)
                                                                      :length 1))
                                                run-list)
                                         (cl:setf last-vp vp)))
                               (cond
                                  ((null last-vp)
                                   (new-run fp vp))
                                  ((eql vp (cl:incf last-vp))
                                   (cl:incf (fr-length run)))
                                  (t (new-run fp vp))))) key-args)
        (reverse run-list)))


(defcommand "EC" (expression) 
          
          (* |;;| "\"eval compiled\"")
 (cl:funcall (cl:compile nil `(cl:lambda nil ,expression))))


(defglobalvar dsktw )

(xcl:reinstall-advice '|\\DoveDisk.HandleMajorError| :before '((:last (prin2 'h dsktw))))
(xcl:reinstall-advice '|\\DoveDisk.TryRecalibrate| :before '((:last (prin2 'r dsktw))))
(xcl:reinstall-advice '(\\dove.xferdisk :in \\dldisk.execute) :after
       '((:last (if (eq !value 'ok)
                    then
                    (prin2 '+ dsktw)
                    else
                    (prin2 '- dsktw)))))

(putprops lfhacks filetype :compile-file)
(putprops lfhacks copyright ("Xerox Corporation" 1987))
(declare\: dontcopy
  (filemap (nil)))
stop
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/LFHACKS.dfasl b/internal/library/OBSOLETE/LFHACKS.dfasl
new file mode 100644
index 00000000..654008cd
Binary files /dev/null and b/internal/library/OBSOLETE/LFHACKS.dfasl differ
diff --git a/internal/library/OBSOLETE/LISPDIAGNOSTICS b/internal/library/OBSOLETE/LISPDIAGNOSTICS
new file mode 100644
index 00000000..ba6d6aa3
--- /dev/null
+++ b/internal/library/OBSOLETE/LISPDIAGNOSTICS
@@ -0,0 +1 @@
+(FILECREATED "19-Dec-84 19:20:52" {ERIS}<LISPCORE>LIBRARY>LISPDIAGNOSTICS.;37 31535  

      changes to:  (FNS DSKPROC.DO1COPY)

      previous date: "16-Dec-84 18:48:51" {ERIS}<LISPCORE>LIBRARY>LISPDIAGNOSTICS.;36)


(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT LISPDIAGNOSTICSCOMS)

(RPAQQ LISPDIAGNOSTICSCOMS ((COMS (* "This would be a good one for the system to have")
				  (FNS UNSHADEALLITEMS printout.SUBR))
			    (INITVARS (DIAGNOSTICSRECORDSTREAM T)
				      (DIAGNOSTICSCONTROLWINDOW.POSITION (create POSITION XCOORD _ 
										 800 YCOORD _ 80)))
			    (VARS (EXERCISE.RUNNER NIL)
				  (EXERCISE.STATE (QUOTE STOP))
				  EXERCISE.POSSIBILITIES)
			    (CONSTANTS \LD.INFOSHADE)
			    (GLOBALVARS DIAGNOSTICSRECORDSTREAM DIAGNOSTICSCONTROLWINDOW.POSITION 
					EXERCISE.RUNNER EXERCISE.STATE EXERCISE.POSSIBILITIES)
			    (FNS EXERCISE \LD.BLOCKCHECK \LD.STOPPROCS)
			    (COMS (* "Some user-interface, menu-like things")
				  (CONSTANTS (\LD.DPM.MENUBORDERSIZE 3))
				  (INITVARS (\LD.DCW.WINDOW NIL)
					    (\LD.DPM.MENU NIL)
					    (\LD.DPM.WINDOW NIL)
					    (\LD.DPM.WINDOWBORDERSIZE NIL)
					    (\LD.DPM.ITEMS NIL)
					    (\LD.DPM.SPACEWIDTH NIL))
				  (FNS MAKEDIAGNOSTICSMENU \LD.DCW.WHENSELECTED \LD.DPM.WHENSELECTED)
				  (GLOBALVARS \LD.DCW.WINDOW \LD.DPM.MENU \LD.DPM.WINDOW 
					      \LD.DPM.WINDOWBORDERSIZE \LD.DPM.FONTHEIGHT 
					      \LD.DPM.ITEMS \LD.DPM.SPACEWIDTH))
			    (DECLARE: EVAL@COMPILE DONTCOPY (RECORDS EXERCISE.POSSIBILITIES)
				      (MACROS ldprintout))
			    (COMS (* "Various background activities to stress hardware")
				  (FNS DSKPROC DSKPROC.AUX DSKPROC.DO1COPY ETHERPROC DAEMONPROC))
			    (COMS (* "Various diagnostic and benchmark activities")
				  (FNS EMUPROC 20RECLAIM)
				  (* "After the TANSPEED benchmark")
				  (FNS \LD.TANSPEED)
				  (* "Extraction from Gabriel's BROWSE benchmark")
				  (FNS \LD.BROWSE \LD.BROWSEINIT \LD.BROWSEMATCH)
				  (VARS (!BROWSEINIT NIL))
				  (GLOBALVARS !BROWSEINIT)
				  (DECLARE: EVAL@COMPILE DONTCOPY (MACROS CHAR1)))
			    (DECLARE: DONTEVAL@COMPILE DONTEVAL@LOAD DOCOPY (* "PPLossage")
				      (ADDVARS (DISPLAYFONTEXTENSIONS STRIKE)
					       (DISPLAYFONTDIRECTORIES {FLOPPY})
					       (LISPUSERSDIRECTORIES {FLOPPY}))
				      (VARS (!MTUSERAIDFLG NIL))
				      (FILES (COMPILED FROM VALUEOF LISPUSERSDIRECTORIES)
					     PAGEHOLD MACROTESTAUX MACROTEST PLURAL)
				      (P (MAKEDIAGNOSTICSMENU)))
			    (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
				      (ADDVARS (NLAMA)
					       (NLAML)
					       (LAMA printout.SUBR)))))



(* "This would be a good one for the system to have")

(DEFINEQ

(UNSHADEALLITEMS
  (LAMBDA (MENU)                                             (* JonL " 1-Dec-84 18:19")
    (PROG ((ITEMS (fetch (MENU ITEMS) of MENU)))
          (MAPC ITEMS (FUNCTION (LAMBDA (ITEM)
		    (SHADEITEM ITEM MENU WHITESHADE)))))))

(printout.SUBR
  (LAMBDA N                                                  (* JonL " 1-Dec-84 22:52")

          (* * Temporarily, this prints out to \TopLevelTtyWindow until we can also make a broadcast stream.)


    (OR (IGEQ N 2)
	(SHOULDNT "Too few args"))
    (bind X (STREAM _(ARG N 1)) for I from 2 to N do (SELECTQ (SETQ X (ARG N I))
							      (T (TERPRI STREAM)
								 (TERPRI \TopLevelTtyWindow))
							      ((, -1)
								(SPACES 1 STREAM)
								(SPACES 1 \TopLevelTtyWindow))
							      (PROGN (PRIN1 X STREAM)
								     (PRIN1 X \TopLevelTtyWindow))))))
)

(RPAQ? DIAGNOSTICSRECORDSTREAM T)

(RPAQ? DIAGNOSTICSCONTROLWINDOW.POSITION (create POSITION XCOORD _ 800 YCOORD _ 80))

(RPAQQ EXERCISE.RUNNER NIL)

(RPAQQ EXERCISE.STATE STOP)

(RPAQQ EXERCISE.POSSIBILITIES ((T (EMUPROC)
				  "BenchMarks")
			       ((AND (HOSTNAMEP (QUOTE DSK))
				     (IGEQ (DISKFREEPAGES)
					   500))
				(DSKPROC)
				"Disk Activity")
			       ((START.CLEARINGHOUSE T)
				(ETHERPROC)
				"Ethernet Activity")
			       (T (DAEMONPROC)
				  "Swap-out WorkingSet")))
(DECLARE: EVAL@COMPILE 

(RPAQQ \LD.INFOSHADE 16920)

(CONSTANTS \LD.INFOSHADE)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DIAGNOSTICSRECORDSTREAM DIAGNOSTICSCONTROLWINDOW.POSITION EXERCISE.RUNNER EXERCISE.STATE 
	    EXERCISE.POSSIBILITIES)
)
(DEFINEQ

(EXERCISE
  (LAMBDA (N)                                                (* JonL "16-Dec-84 17:09")
    (SETQ EXERCISE.STATE NIL)
    (RESETLST (PROG ((OEMS ERRORMESSAGESTREAM)
		     (ODRS DIAGNOSTICSRECORDSTREAM)
		     (DPM.FONT MENUFONT)
		     RUNNINGPROCS MENUSTATE DCWMENU DCWITEMS)
		    (if (AND (EQ DIAGNOSTICSRECORDSTREAM T)
			     (HOSTNAMEP (QUOTE DSK)))
			then (RESETSAVE (SETQ DIAGNOSTICSRECORDSTREAM (OPENSTREAM (QUOTE 
									   {DSK}DIAGNOSTICSRECORD)
										  (QUOTE OUTPUT)))
					(QUOTE (PROGN (CLOSEF? OLDVALUE)
						      (SETQ DIAGNOSTICSRECORDSTREAM T)))))
		    (if (EQ ERRORMESSAGESTREAM T)
			then (SETQ ERRORMESSAGESTREAM DIAGNOSTICSRECORDSTREAM))
		    (if (WINDOWP \LD.DCW.WINDOW)
			then (DETACHALLWINDOWS \LD.DCW.WINDOW)
		      else (MAKEDIAGNOSTICSMENU))
		    (OPENW \LD.DCW.WINDOW)
		    (UNSHADEALLITEMS (SETQ DCWMENU (CAR (WINDOWPROP \LD.DCW.WINDOW (QUOTE MENU)))))
		    (SHADEITEM (ASSOC (QUOTE StartExercise)
				      (SETQ DCWITEMS (fetch (MENU ITEMS) of DCWMENU)))
			       DCWMENU \LD.INFOSHADE)
		    (SETQ RUNNINGPROCS (SETQ \LD.DPM.ITEMS))
		    (SETQ \LD.DPM.SPACEWIDTH (STRINGWIDTH " " DPM.FONT))
		    (SETQ \LD.DPM.FONTHEIGHT (FONTHEIGHT DPM.FONT))
		    (bind PROC for \Possibility in (PROG1 EXERCISE.POSSIBILITIES 
                                                             (* Comment PPLossage))
		       as THISHEIGHT from 0 by (IPLUS \LD.DPM.FONTHEIGHT \LD.DPM.MENUBORDERSIZE)
		       eachtime (if (EQ EXERCISE.STATE (QUOTE STOP))
				    then (RETURN (SETQ RUNNINGPROCS)))
		       when (SETQ PROC
			      (CAR (LISTP (NLSETQ (PROGN (NLSETQ (DEL.PROCESS
								   (CAR (fetch (EXERCISE.POSSIBILITIES
										 PROCFORM)
									   of \Possibility))))
							 (AND (EVAL (fetch (EXERCISE.POSSIBILITIES
									     TESTFORM)
								       of \Possibility))
							      (ADD.PROCESS (fetch (
EXERCISE.POSSIBILITIES PROCFORM) of \Possibility)
									   (QUOTE SUSPEND)
									   T)))))))
		       do (DECLARE (SPECVARS \Possibility))
			  (push \LD.DPM.ITEMS (LIST (CONCAT " " (fetch (EXERCISE.POSSIBILITIES 
										     MENUITEMFORM)
								   of \Possibility))
						    NIL "LEFT to WakeUp, MIDDLE to Suspend"
						    (LIST (PROCESS.NAME PROC)
							  THISHEIGHT)))
			  (push RUNNINGPROCS PROC))
		    (if (OR (NULL RUNNINGPROCS)
			    (EQ EXERCISE.STATE (QUOTE STOP)))
			then (UNSHADEALLITEMS DCWMENU)
			     (RETURN (QUOTE ABORT)))
		    (SETQ \LD.DPM.MENU
		      (create MENU
			      ITEMS _ \LD.DPM.ITEMS
			      MENUFONT _ DPM.FONT
			      MENUBORDERSIZE _ 1
			      MENUCOLUMNS _ 1
			      WHENSELECTEDFN _(FUNCTION \LD.DPM.WHENSELECTED)))
		    (SETQ \LD.DPM.ITEMS (fetch (MENU ITEMS) of \LD.DPM.MENU))
                                                             (* Just to be sure of the right EQality!)
		    (ATTACHMENU \LD.DPM.MENU \LD.DCW.WINDOW (QUOTE TOP)
				(QUOTE RIGHT))
		    (SETQ \LD.DPM.WINDOW (OR (CAR (ATTACHEDWINDOWS \LD.DCW.WINDOW))
					     (SHOULDNT)))
		    (SETQ \LD.DPM.WINDOWBORDERSIZE (WINDOWPROP \LD.DPM.WINDOW (QUOTE BORDER)))
		    (SETQ EXERCISE.RUNNER)
		    (SETQ EXERCISE.STATE (QUOTE RUNNING))
		    (printout.SUBR DIAGNOSTICSRECORDSTREAM T "			Legend" T T 
				   "! -> Completed !DIAGNOSE of MACROTEST"
				   T "@ -> Completed TANSPEED benchmark" T 
				   "# -> Completed BROWSE benchmark"
				   T "$ - > Found a Clearing House on the EtherNet" T 
				   "- -> Looked, but faild to find a Clearing House"
				   T "[xxx] -> Tried 32 retrievals from CH and got xxx failures" T T 
				   "{xxx} - > Copied and deleted xxx copies of the Disk file"
				   "(xxx) -> Finished with xxx'th run of the EMUPROC loop." T 
				   "GDATE on new line marks release of working set pages."
				   T T T)
		    (MAPC RUNNINGPROCS (FUNCTION WAKE.PROCESS))
		    (SHADEITEM (ASSOC (QUOTE StartExercise)
				      DCWITEMS)
			       DCWMENU WHITESHADE)
		LP                                           (* Just let the processes run until we STOP them)
		    (if (OR (EQ (SETQ MENUSTATE (BLOCK 10000))
				(QUOTE STOP))
			    (EQ EXERCISE.STATE (QUOTE STOP)))
			then (PROG ((MENU (CAR (WINDOWPROP \LD.DCW.WINDOW (QUOTE MENU))))
				    ITEM)
			           (AND (SETQ ITEM (ASSOC (QUOTE StopExercise)
							  (fetch (MENU ITEMS) of MENU)))
					(SHADEITEM ITEM MENU \LD.INFOSHADE))
			           (\LD.STOPPROCS RUNNINGPROCS MENU)
			           (DETACHALLWINDOWS \LD.DCW.WINDOW)
			           (AND (NEQ DIAGNOSTICSRECORDSTREAM T)
					(CLOSEF DIAGNOSTICSRECORDSTREAM))
			           (AND ITEM (SHADEITEM ITEM MENU WHITESHADE)))
			     (SETQ ERRORMESSAGESTREAM OEMS)
			     (SETQ DIAGNOSTICSRECORDSTREAM ODRS)
			     (RETURN (QUOTE STOP))
		      elseif MENUSTATE
			then                                 (* Someday, look for more interesting signals)
			)
		    (GO LP)))))

(\LD.BLOCKCHECK
  (LAMBDA (TIME POS NAME)                                    (* JonL "16-Dec-84 17:10")
    (PROG ((SIGNAL (if (DISMISS TIME)
		     elseif (NULL TIME)
		       then                                  (* Allow two passes around the scheduler loop when 
							     blocking for 0 time; this helps the MOUSE tracker)
			    (BLOCK)))
	   NEWP OLDP)
          (if (OR (EQ SIGNAL (QUOTE STOP))
		  (EQ EXERCISE.STATE (QUOTE STOP)))
	      then (RETFROM POS (QUOTE STOP))
	    elseif SIGNAL
	      then                                           (* Do some action precipitaed by the menu)
	      )
          (if (EQ NAME (QUOTE DON'T))
	      then (RETURN)
	    elseif (AND NAME (LITATOM NAME))
	    elseif (AND POS (LITATOM POS))
	      then (SETQ NAME POS)
	    else (SHOULDNT))
          (if (SETQ NEWP (find ITEM in \LD.DPM.ITEMS suchthat (EQ NAME (CAR (CADDDR ITEM)))))
	      then (if (AND EXERCISE.RUNNER (SETQ OLDP (find ITEM in \LD.DPM.ITEMS
							  suchthat (EQ EXERCISE.RUNNER
								       (CAR (CADDDR ITEM))))))
		       then                                  (* First, take away the "baton" from the old process)
			    (BITBLT NIL NIL NIL \LD.DPM.WINDOW \LD.DPM.WINDOWBORDERSIZE
				    (CADR (CADDDR OLDP))
				    \LD.DPM.SPACEWIDTH \LD.DPM.FONTHEIGHT (QUOTE TEXTURE)
				    (QUOTE REPLACE)
				    WHITESHADE))
		   (BITBLT NIL 0 0 \LD.DPM.WINDOW \LD.DPM.WINDOWBORDERSIZE (CADR (CADDDR NEWP))
			   \LD.DPM.SPACEWIDTH \LD.DPM.FONTHEIGHT (QUOTE TEXTURE)
			   (QUOTE REPLACE)
			   BLACKSHADE)                       (* Here, we give the "baton" to the process NAME -- by 
							     turning on some bits in the menuitem reflecting that 
							     process)
		   (SETQ EXERCISE.RUNNER NAME)))))

(\LD.STOPPROCS
  (LAMBDA (PROCS MENU)                                       (* JonL " 1-Dec-84 21:13")

          (* When we want to stop, the find out who is still alive, and give them the STOP signal; then wait around for 60 
	  seconds so to see if they "give up" gracefully.)


    (MAPC (SETQ PROCS (MAPCONC (MKLIST PROCS)
			       (FUNCTION (LAMBDA (PROC)
				   (AND (PROCESSP PROC)
					(LIST PROC))))))
	  (FUNCTION (LAMBDA (PROC)
	      (WAKE.PROCESS PROC (QUOTE STOP)))))
    (bind STOPPERS PN forDuration 60 timerUnits (QUOTE SECONDS) until (NULL PROCS) eachtime (BLOCK)
       when (SETQ STOPPERS (for P in PROCS when (PROCESS.FINISHEDP P) collect P))
       do (SETQ PROCS (LDIFFERENCE PROCS STOPPERS))
	  (for P ITEM in STOPPERS
	     do (SETQ PN (PROCESS.NAME P))
		(if (SETQ ITEM (find ITEM in \LD.DPM.ITEMS suchthat (EQ PN (CAR (CADDDR ITEM)))))
		    then (SHADEITEM ITEM MENU DARKBITSHADE))))
    (if PROCS
	then (printout.SUBR DIAGNOSTICSRECORDSTREAM T "Processes which didn't terminate normally: "
			    (MAPCAR PROCS (QUOTE PROCESS.NAME))
			    T)
	     (MAPC PROCS (FUNCTION DEL.PROCESS)))))
)



(* "Some user-interface, menu-like things")

(DECLARE: EVAL@COMPILE 

(RPAQQ \LD.DPM.MENUBORDERSIZE 3)

(CONSTANTS (\LD.DPM.MENUBORDERSIZE 3))
)

(RPAQ? \LD.DCW.WINDOW NIL)

(RPAQ? \LD.DPM.MENU NIL)

(RPAQ? \LD.DPM.WINDOW NIL)

(RPAQ? \LD.DPM.WINDOWBORDERSIZE NIL)

(RPAQ? \LD.DPM.ITEMS NIL)

(RPAQ? \LD.DPM.SPACEWIDTH NIL)
(DEFINEQ

(MAKEDIAGNOSTICSMENU
  (LAMBDA NIL                                                (* JonL "16-Dec-84 17:06")
    (AND (WINDOWP \LD.DCW.WINDOW)
	 (CLOSEW \LD.DCW.WINDOW))
    (SETQ \LD.DCW.WINDOW (ADDMENU (create MENU
					  ITEMS _(QUOTE ((StartExercise
							    (PROG ((\INTERRUPTABLE NIL))
							          (SETQ EXERCISE.STATE (QUOTE RUN))
							          (ADD.PROCESS (QUOTE (EXERCISE))))
							    "Begins diagnostic suite processes")
							  (StopExercise (WAKE.PROCESS (QUOTE EXERCISE)
										      (SETQ 
										   EXERCISE.STATE
											(QUOTE STOP)))
									
					    "Stops and deletes the diagnostic processes (if any)")))
					  WHENSELECTEDFN _(FUNCTION \LD.DCW.WHENSELECTED)
					  MENUFONT _(FONTCREATE (QUOTE HELVETICA)
								18)
					  MENUTITLEFONT _(FONTCREATE (QUOTE TIMESROMAN)
								     12)
					  TITLE _ "Diagnostics Control"
					  CENTERFLG _ T
					  ITEMHEIGHT _ 30
					  ITEMWIDTH _(IMAX 150 (IPLUS 20 (STRINGWIDTH
									"StartExercise"
									(FONTCREATE (QUOTE HELVETICA)
										    18))))
					  MENUBORDERSIZE _ \LD.DPM.MENUBORDERSIZE)
				  NIL DIAGNOSTICSCONTROLWINDOW.POSITION))
    (WINDOWPROP \LD.DCW.WINDOW (QUOTE AFTERMOVEFN)
		(FUNCTION (LAMBDA (WINDOW)
		    (OR (EQ WINDOW \LD.DCW.WINDOW)
			(SHOULDNT))
		    (PROG ((REG (WINDOWPROP WINDOW (QUOTE REGION))))
		          (SETQ DIAGNOSTICSCONTROLWINDOW.POSITION (create POSITION
									  XCOORD _(fetch
									    (REGION LEFT)
										     of REG)
									  YCOORD _(fetch
									    (REGION BOTTOM)
										     of REG)))))))
    (WINDOWPROP \LD.DCW.WINDOW (QUOTE RESHAPEFN)
		(QUOTE DON'T))
    (WINDOWPROP \LD.DCW.WINDOW (QUOTE CLOSEFN)
		(FUNCTION (LAMBDA (WINDOW)
		    (SETQ \LD.DCW.WINDOW))))
    \LD.DCW.WINDOW))

(\LD.DCW.WHENSELECTED
  (LAMBDA (ITEM MENU BUTTON)                                 (* JonL " 1-Dec-84 18:29")
    (SHADEITEM ITEM MENU GRAYSHADE)
    (EVAL (CADR ITEM))))

(\LD.DPM.WHENSELECTED
  (LAMBDA (ITEM MENU BUTTON)                                 (* JonL " 1-Dec-84 00:08")
    (PROG ((STUFF (CADDDR ITEM)))

          (* This STUFF in the 4th slot of the menuitem should be a list of the process name and the height in the menuwindow 
	  of this item.)


          (APPLY* (SELECTQ BUTTON
			   (LEFT (FUNCTION WAKE.PROCESS))
			   (MIDDLE (FUNCTION SUSPEND.PROCESS))
			   (RETURN))
		  (OR (FIND.PROCESS (CAR STUFF))
		      (RETURN))))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \LD.DCW.WINDOW \LD.DPM.MENU \LD.DPM.WINDOW \LD.DPM.WINDOWBORDERSIZE \LD.DPM.FONTHEIGHT 
	    \LD.DPM.ITEMS \LD.DPM.SPACEWIDTH)
)
(DECLARE: EVAL@COMPILE DONTCOPY 
[DECLARE: EVAL@COMPILE 

(RECORD EXERCISE.POSSIBILITIES (TESTFORM PROCFORM MENUITEMFORM))
]

(DECLARE: EVAL@COMPILE 

(PUTPROPS ldprintout MACRO ((STREAM . REST)
  (PROGN                                                     (* How we'd like a broadcast stream here!)
	 (printout STREAM . REST)
	 (printout \TopLevelTtyWindow . REST))))
)
)



(* "Various background activities to stress hardware")

(DEFINEQ

(DSKPROC
  (LAMBDA (N)                                                (* JonL "16-Dec-84 18:27")
                                                             (* Cause a lot of DSK activity)
    (RESETLST (RESETSAVE NIL (QUOTE (PROGN (CLOSEF? (QUOTE {DSK}RANDOMDATA))
					   (CLOSEF? (QUOTE {CORE}RANDOMDATA))
					   (until (NULL (DELFILE (QUOTE {DSK}RANDOMDATA))))
					   (until (NULL (DELFILE (QUOTE {CORE}RANDOMDATA))))
					   (RESETLST (PROG1 
                                                             (* Comment PPLossage))
						     (RESETSAVE (CNDIR (QUOTE {DSK}))
								(LIST (FUNCTION CNDIR)
								      (DIRECTORYNAME T)))
						     ((LAMBDA (X)
							 (MAPC X (FUNCTION CLOSEF?))
							 (MAPC X (FUNCTION DELFILE)))
						       (DIRECTORY (QUOTE TEMPRANDOMCOPY*)))))))
	      (DSKPROC.AUX N))))

(DSKPROC.AUX
  (LAMBDA (N)                                                (* JonL "16-Dec-84 18:44")
    (OR (FIXP N)
	(SETQ N MAX.SMALLP))
    (PROG (SOURCE CORESOURCE NFILES)
          (until (NULL (DELFILE (QUOTE {DSK}RANDOMDATA))))
          (until (NULL (DELFILE (QUOTE {CORE}RANDOMDATA))))
          (SETQ CORESOURCE (OPENFILE (QUOTE {CORE}RANDOMDATA)
				     (QUOTE OUTPUT)))        (* First, create a moderately large file to copy)
          (for I from 0 to 99
	     do (\LD.BLOCKCHECK 100 (QUOTE DSKPROC.AUX)
				(QUOTE DSKPROC))
		(for J from 0 to 9 do (printout CORESOURCE "Now here's yet another line, the "
						(IPLUS (ITIMES I 10)
						       J 1)
						"'th one." T)))
          (TERPRI CORESOURCE)
          (CLOSEF CORESOURCE)
          (SETQ SOURCE (DSKPROC.DO1COPY CORESOURCE (QUOTE {DSK}RANDOMDATA)
					CORESOURCE))
          (printout.SUBR DIAGNOSTICSRECORDSTREAM T 
			 "Finished initializing the source file for DSKPROC"
			 T)
          (\LD.BLOCKCHECK 250 (QUOTE DSKPROC.AUX)
			  (QUOTE DSKPROC))                   (* Then make a random number of copies, and then delete
							     them)
          (to N
	     do (MAPC (bind SS DS to (SETQ NFILES (RAND 3 7))
			 collect (\LD.BLOCKCHECK (ITIMES 1000 (RAND 1 5))
						 (QUOTE DSKPROC.AUX)
						 (QUOTE DSKPROC))
				 (DSKPROC.DO1COPY SOURCE (PACK* (QUOTE {DSK}TEMPRANDOMCOPY)
								(SELECTC (RAND 1 5)
									 (1 "25.TXT")
									 (2 ".TXT")
									 (3 "MUMBLE")
									 (4 "2345.MUMBLE")
									 (5 "")
									 (SHOULDNT)))
						  CORESOURCE))
		      (FUNCTION (LAMBDA (FILE)
			  (\LD.BLOCKCHECK 250 (QUOTE DSKPROC.AUX)
					  (QUOTE DSKPROC))
			  (DELFILE FILE))))
		(printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE {)
			       NFILES
			       (QUOTE }))))))

(DSKPROC.DO1COPY
  (LAMBDA (SOURCE DESTINATION CORESOURCE)                    (* JonL "19-Dec-84 18:53")
    (LET ((SS (OPENSTREAM SOURCE (QUOTE INPUT)))
          (DS (OPENSTREAM DESTINATION (QUOTE OUTPUT)))
          (FILELEN 0)
          THISROUND)
      (SETQ FILELEN (GETFILEINFO SS (QUOTE LENGTH)))
      (bind (NBYTES _ FILELEN) while (IGREATERP NBYTES 0)
	 do (\LD.BLOCKCHECK 250 (QUOTE DSKPROC.AUX)
			    (QUOTE DSKPROC))
	    (to (SETQ THISROUND (IMIN NBYTES 512)) do (BOUT DS (BIN SS)))
	    (add NBYTES (IMINUS THISROUND)))
      (CLOSEF DS)
      (\LD.BLOCKCHECK 250 (QUOTE DSKPROC.AUX)
		      (QUOTE DSKPROC))
      (if CORESOURCE
	  then (CLOSEF SS)
	       (SETQ SS (OPENSTREAM CORESOURCE (QUOTE INPUT)))
	else (SETFILEPTR SS 0))
      (SETQ DS (OPENSTREAM DS (QUOTE INPUT)))                (* Now compare the file to see that it "made it")
      (if (NEQ FILELEN (GETFILEINFO DS (QUOTE LENGTH)))
	  then (!MRAID DESTINATION "DSK copy failure -- wrong length")
	else (bind (NBYTES _ FILELEN)
		   (I _ -1) while (IGREATERP NBYTES 0)
		do (\LD.BLOCKCHECK 250 (QUOTE DSKPROC.AUX)
				   (QUOTE DSKPROC))
		   (to (SETQ THISROUND (IMIN NBYTES 512)) eachtime (PROG1 (add I 1)
                                                             (* Comment PPLossage)
									  )
		      when (NEQ (BIN SS)
				(BIN DS))
		      do (!MRAID DESTINATION (CONCAT "DSK copy failure -- data different at filepos " 
						     I))
			 (RETURN (SETQ THISROUND)))
		   (add NBYTES (IMINUS (OR THISROUND (RETURN))))))
      (CLOSEF SS)
      (CLOSEF DS)
      (\LD.BLOCKCHECK 500 (QUOTE DSKPROC.AUX)
		      (QUOTE DSKPROC))
      (FULLNAME DS))))

(ETHERPROC
  (LAMBDA (N)                                                (* JonL " 9-Dec-84 13:45")
    (DECLARE (GLOBALVARS LOCAL.CLEARINGHOUSE))
    (OR (FIXP N)
	(SETQ N MAX.SMALLP))
    (for I to N
       bind (J _ 0)
	    (JF _ 0)
       do (if (EVENP I 64)
	      then (\LD.BLOCKCHECK 1000 (QUOTE ETHERPROC))
		   (SETQ LOCAL.CLEARINGHOUSE)
		   (printout.SUBR DIAGNOSTICSRECORDSTREAM (if (CAR (LISTP (NLSETQ (START.CLEARINGHOUSE
										    T))))
							      then (QUOTE $)
							    else (QUOTE -))))
	  (if LOCAL.CLEARINGHOUSE
	      then (\LD.BLOCKCHECK (if (EVENP I 8)
				       then 1000
				     else NIL)
				   (QUOTE ETHERPROC))
		   (if (CAR (LISTP (NLSETQ (CH.LIST.ORGANIZATIONS))))
		     else (add JF 1))
		   (if (IGEQ (add J 1)
			     32)
		       then (SETQ J 1)
			    (printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE %[)
					   JF
					   (QUOTE %]))
			    (SETQ JF 0))
	    else (\LD.BLOCKCHECK 20000 (QUOTE ETHERPROC))
		 (SETQ LOCAL.CLEARINGHOUSE)
		 (NLSETQ (START.CLEARINGHOUSE T))))))

(DAEMONPROC
  (LAMBDA (N)                                                (* JonL " 7-Dec-84 01:37")
    (OR (FIXP N)
	(SETQ N MAX.SMALLP))
    (to N
       do (to (CONSTANT (QUOTIENT (TIMES 10 60)
				  10))
	     do (\LD.BLOCKCHECK 10000 (QUOTE DAEMONPROC)
				(QUOTE DON'T)))

          (* * Random perturbation of the working set every 10 minutes +or- a few seconds)


	  (\LD.BLOCKCHECK (ITIMES 1000 (RAND 5 10))
			  (QUOTE DAEMONPROC))
	  (\RELEASEWORKINGSET)
	  (printout.SUBR DIAGNOSTICSRECORDSTREAM T (GDATE)
			 T))))
)



(* "Various diagnostic and benchmark activities")

(DEFINEQ

(EMUPROC
  (LAMBDA (N)                                                (* JonL " 7-Dec-84 01:23")
                                                             (* Basically, just runs a lot of test of emulator 
							     instructons)
    (OR (FIXP N)
	(SETQ N MAX.SMALLP))                                 (* First, run the standard MACROTEST diagnostics)
    (for RUN# to N
       do (if (AND (GETD (QUOTE !NUMBERTEST))
		   (GETD (QUOTE CHECKFREELISTS)))
	      then (for TEST in (QUOTE (!NUMBERTEST !FNUMTEST !MIXNUMTEST !GCTEST !CONSTEST !FVARTEST 
						    !INTERPTEST CHECKCONSPAGES CHECKFREELISTS 
						    20RECLAIM CHECKFREELISTS))
		      do (\LD.BLOCKCHECK 500 (QUOTE EMUPROC))
			 (APPLY* TEST))
		   (printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE !)))
	  (\LD.BLOCKCHECK (ITIMES 1000 (RAND 1 5))
			  (QUOTE EMUPROC))
	  (\LD.TANSPEED)
	  (\LD.BLOCKCHECK (ITIMES 1000 (RAND 1 5))
			  (QUOTE EMUPROC))
	  (\LD.BROWSE)
	  (\LD.BLOCKCHECK 1000 (QUOTE EMUPROC))
	  (printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE %()
			 RUN#
			 (QUOTE %))))))

(20RECLAIM
  (LAMBDA NIL                                                (* JonL "28-Nov-84 13:52")
    (FRPTQ 20 (RECLAIM))))
)



(* "After the TANSPEED benchmark")

(DEFINEQ

(\LD.TANSPEED
  (LAMBDA NIL                                                (* JonL " 7-Dec-84 01:22")
                                                             (* TANSPEED benchmark is a fairly good test of floating
							     point arithmetic also)
    (for I F (A _ 1.0) from 0 to 2498
       do (AND (EVENP I 32)
	       (\LD.BLOCKCHECK 500 (QUOTE EMUPROC)))
	  (SETQ A (FPLUS (TAN (ARCTAN (ANTILOG (LOG (SQRT (FTIMES A A))))
				      T)
			      T)
			 1.0))
       finally (if (LESSP 25.0 (ABS (SETQ F (DIFFERENCE A 2500.0))))
		   then (!MRAID (LIST (QUOTE (TANSPEED))
				      (QUOTE =>)
				      F
				      (QUOTE should-have-been)
				      2476.246))
		 else (printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE @))))))
)



(* "Extraction from Gabriel's BROWSE benchmark")

(DEFINEQ

(\LD.BROWSE
  (LAMBDA NIL                                                (* JonL " 7-Dec-84 01:23")
                                                             (* Unfortunately, this has to be a copy of the code in 
							     BROWSE since we want to do the init phase only once)
    (if !BROWSEINIT
      else (SETQ !BROWSEINIT
	     (\LD.BROWSEINIT 100 10 4
			     (QUOTE ((A A A B B B B A A A A A B B A A A)
				      (A A B B B B A A (A A)
					 (B B))
				      (A A A B (B A)
					 B A B A))))))
    (for UNITS
       on (bind A N (RAND _ 21)
		(L _ !BROWSEINIT) while L
	     do (\LD.BLOCKCHECK NIL (QUOTE EMUPROC))
		(if (EQ 0 (SETQ N (IMOD (SETQ RAND (IMOD (ITIMES RAND 17)
							 251))
					(LENGTH L))))
		    then (push A (pop L))
		  else (for N from N to 2 by -1 as X on L do NIL finally (PROGN (push A (CADR X))
										(RPLACD X
											(CDDR X)))))
	     finally (RETURN A))
       do (for PATS on (QUOTE ((*A ?B *B ?B A *A A *B *A)
				(*A *B *B *A (*A)
				    (*B))
				(? ? *(B A)* ? ?)))
	     do (for P on (GETP (CAR UNITS)
				(QUOTE PATTERN))
		   do (\LD.BLOCKCHECK NIL (QUOTE EMUPROC))
		      (\LD.BROWSEMATCH (CAR PATS)
				       (CAR P)
				       NIL))))
    (printout.SUBR DIAGNOSTICSRECORDSTREAM (QUOTE #))))

(\LD.BROWSEINIT
  (LAMBDA (N M NPATS IPATS)                                  (* JonL "30-Nov-84 22:50")
    (SETQ IPATS (SUBST NIL NIL IPATS))
    (bind (A _ NIL)
	  (LOSER _(LAST IPATS)) first (RPLACD LOSER IPATS) for old N from N to 1 by -1
       as (I _ M) by (if (ZEROP I)
			 then M
		       else (SUB1 I))
       as (NAME _(GENSYM)) by (GENSYM)
       do (\LD.BLOCKCHECK NIL (QUOTE EMUPROC))
	  (push A NAME)
	  (RPTQ I (PUTPROP NAME (GENSYM)
			   NIL))
	  (PUTPROP NAME (QUOTE PATTERN)
		   (bind (A _ NIL) for I from NPATS to 1 by -1 as IPATS on IPATS
		      do (push A (CAR IPATS)) finally (RETURN A)))
	  (RPTQ (DIFFERENCE M I)
		(PUTPROP NAME (GENSYM)
			 NIL))
       finally (PROGN                                        (* Just to break the circularity)
		      (RPLACD LOSER NIL)
		      (RETURN A)))))

(\LD.BROWSEMATCH
  (LAMBDA (PAT DAT ALIST)                                    (* JonL "25-FEB-83 13:38")
    (COND
      ((NULL PAT)
	(NULL DAT))
      ((NULL DAT)
	NIL)
      ((OR (EQ (CAR PAT)
	       (QUOTE ?))
	   (EQ (CAR PAT)
	       (CAR DAT)))
	(\LD.BROWSEMATCH (CDR PAT)
			 (CDR DAT)
			 ALIST))
      ((EQ (CAR PAT)
	   (QUOTE *))
	(OR (\LD.BROWSEMATCH (CDR PAT)
			     DAT ALIST)
	    (\LD.BROWSEMATCH (CDR PAT)
			     (CDR DAT)
			     ALIST)
	    (\LD.BROWSEMATCH PAT (CDR DAT)
			     ALIST)))
      (T (COND
	   ((NLISTP (CAR PAT))
	     (COND
	       ((EQ (CHAR1 (CAR PAT))
		    (QUOTE ?))
		 (PROG ((VAL (FASSOC (CAR PAT)
				     ALIST)))
		       (RETURN (COND
				 (VAL (\LD.BROWSEMATCH (CONS (CDR VAL)
							     (CDR PAT))
						       DAT ALIST))
				 (T (\LD.BROWSEMATCH (CDR PAT)
						     (CDR DAT)
						     (CONS (CONS (CAR PAT)
								 (CAR DAT))
							   ALIST)))))))
	       ((EQ (CHAR1 (CAR PAT))
		    (QUOTE *))
		 (PROG ((VAL (FASSOC (CAR PAT)
				     ALIST)))
		       (RETURN (COND
				 (VAL (\LD.BROWSEMATCH (APPEND (CDR VAL)
							       (CDR PAT))
						       DAT ALIST))
				 (T (for (L _ NIL) by (NCONC L (LIST (CAR D))) as E
				       on (CONS NIL DAT) as (D _ DAT) by (CDR D)
				       do (COND
					    ((\LD.BROWSEMATCH (CDR PAT)
							      D
							      (CONS (CONS (CAR PAT)
									  L)
								    ALIST))
					      (RETURN T)))))))))))
	   (T (AND (NOT (NLISTP (CAR DAT)))
		   (\LD.BROWSEMATCH (CAR PAT)
				    (CAR DAT)
				    ALIST)
		   (\LD.BROWSEMATCH (CDR PAT)
				    (CDR DAT)
				    ALIST))))))))
)

(RPAQQ !BROWSEINIT NIL)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS !BROWSEINIT)
)
(DECLARE: EVAL@COMPILE DONTCOPY 
(DECLARE: EVAL@COMPILE 

(PUTPROPS CHAR1 MACRO ((X) (NTHCHAR X 1)))
)
)
(DECLARE: DONTEVAL@COMPILE DONTEVAL@LOAD DOCOPY 

(ADDTOVAR DISPLAYFONTEXTENSIONS STRIKE)

(ADDTOVAR DISPLAYFONTDIRECTORIES {FLOPPY})

(ADDTOVAR LISPUSERSDIRECTORIES {FLOPPY})


(RPAQQ !MTUSERAIDFLG NIL)

(FILESLOAD (COMPILED FROM VALUEOF LISPUSERSDIRECTORIES)
	   PAGEHOLD MACROTESTAUX MACROTEST PLURAL)

(MAKEDIAGNOSTICSMENU)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA printout.SUBR)
)
(PUTPROPS LISPDIAGNOSTICS COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2711 3681 (UNSHADEALLITEMS 2721 . 3006) (printout.SUBR 3008 . 3679)) (4453 13303 (
EXERCISE 4463 . 9943) (\LD.BLOCKCHECK 9945 . 11961) (\LD.STOPPROCS 11963 . 13301)) (13663 16365 (
MAKEDIAGNOSTICSMENU 13673 . 15632) (\LD.DCW.WHENSELECTED 15634 . 15824) (\LD.DPM.WHENSELECTED 15826 . 
16363)) (17007 23842 (DSKPROC 17017 . 17977) (DSKPROC.AUX 17979 . 20024) (DSKPROC.DO1COPY 20026 . 
21970) (ETHERPROC 21972 . 23219) (DAEMONPROC 23221 . 23840)) (23901 25276 (EMUPROC 23911 . 25131) (
20RECLAIM 25133 . 25274)) (25320 26202 (\LD.TANSPEED 25330 . 26200)) (26260 30754 (\LD.BROWSE 26270 . 
27769) (\LD.BROWSEINIT 27771 . 28807) (\LD.BROWSEMATCH 28809 . 30752)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/LISPDIAGNOSTICS.TEDIT b/internal/library/OBSOLETE/LISPDIAGNOSTICS.TEDIT
new file mode 100644
index 00000000..dc181eb8
Binary files /dev/null and b/internal/library/OBSOLETE/LISPDIAGNOSTICS.TEDIT differ
diff --git a/internal/library/OBSOLETE/LLCOLOR b/internal/library/OBSOLETE/LLCOLOR
new file mode 100644
index 00000000..e5c4cffc
--- /dev/null
+++ b/internal/library/OBSOLETE/LLCOLOR
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 17:35:17" {DSK}<usr>local>lde>lispcore>internal>library>LLCOLOR.;2 129383 

      changes to%:  (VARS LLCOLORCOMS)

      previous date%: "16-Jan-87 17:37:34" {DSK}<usr>local>lde>lispcore>internal>library>LLCOLOR.;1
)


(* ; "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT LLCOLORCOMS)

(RPAQQ LLCOLORCOMS
       [(FNS COLORDISPLAY COLORMAPBITS \CreateColorScreenBitMap \CREATECOLORDISPLAYFDEV COLORMAP 
             SCREENCOLORMAP SCREENCOLORMAPENTRY ROTATECOLORMAP RGBCOLORMAP CMYCOLORMAP GRAYCOLORMAP 
             COLORSCREENBITMAP \COLORDISPLAYBITS COLORSCREEN SHOWCOLORTESTPATTERN)
        (INITVARS (COLORMONITORTYPE 'CONRAC))
        (FNS \STARTCOLOR \STOPCOLOR \SENDCOLORMAPENTRY)
        (FNS COLORMAPCREATE COLORLEVEL COLORNUMBERP COLORFROMRGB INTENSITIESFROMCOLORMAP 
             SETCOLORINTENSITY)
        (FNS \FAST8BIT \MAP4 \MAP8)
        (FNS \GETCOLORBRUSH)
        (FNS \DRAWCOLORLINE1 \DRAW4BPPCOLORLINE \DRAW8BPPCOLORLINE \DRAW24BPPCOLORLINE)
        (DECLARE%: DONTCOPY DOEVAL@COMPILE (MACROS .DRAW4BPPLINEX. .DRAW8BPPLINEX .DRAW24BPPLINEX 
                                                  .DRAW4BPPLINEY. .DRAW8BPPLINEY .DRAW24BPPLINEY))
        (FNS \BWTOCOLORBLT \4BITLINEBLT \8BITLINEBLT \24BITLINEBLT \GETBASE24 \PUTBASE24 
             COLORTEXTUREFROMCOLOR# \BITMAPWORD)
        (FNS COLORIZEBITMAP UNCOLORIZEBITMAP)
        (INITVARS (\1COLORMENU NIL)
               (\4COLORMENU NIL)
               (\8COLORMENU NIL))
        (FNS COLORMENU CURSORCOLOR)
        (RECORDS RGB HLS)
        (DECLARE%: DONTCOPY (RECORDS NIBBLES ONEOFFSETBITACCESS TWOOFFSETBITACCESS 
                                   THREEOFFSETBTACCESS 2BITNIBBLES ODD2BITNIBBLES))
        (CONSTANTS (BITSPERWORD 16))
        (INITVARS (\COLORDISPLAYFDEV)
               (\4COLORMAP (CMYCOLORMAP 2 1 1 4))
               (\8COLORMAP (CMYCOLORMAP 3 3 2 8))
               (\COLORDISPLAYBITS)
               (ColorScreenBitMap)
               (\COLORSCREEN))
        (FNS PSEUDOCOLOR \PSEUDOCOLOR.BITMAP \PSEUDOCOLOR.UFN)
        (GLOBALVARS \COLORDISPLAYFDEV \COLORDISPLAYBITS ColorScreenBitMap \4COLORMAP \8COLORMAP)
        (P (* NOTE%: This is very bad. I shouldn't have to and don't really want to do the following,
              but since about March 86, someone did something really nonstandard wrt Helvetica fonts
              so that the in core versions are not equal to what is stored on file. The 
              SETFONTDESCRIPTOR and friends undoes this kludge which has never been explained to 
              LISPCORE^ by the person who brain damaged Helvetica this way. If I don't undo this 
              kludge by someone else, then color menus come out wrong. *)
           (SETFONTDESCRIPTOR 'HELVETICA 10 'MRR 0 'DISPLAY NIL)
           (SETQ MENUFONT (FONTCREATE 'HELVETICA 10)))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA])
(DEFINEQ

(COLORDISPLAY
  [LAMBDA (ONOFF TYPE)                                       (* kbr%: " 5-Jun-86 20:53")
                                                             (* Turn hardware TYPE color display on 
                                                             or off. *)
    (PROG (OLDONOFF OLDTYPE DISPLAYSTATE DISPLAYINFO)
          [COND
             (\COLORDISPLAYFDEV (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of \COLORDISPLAYFDEV))
                    (SETQ DISPLAYINFO (fetch (FDEV WINDOWDATA) of \COLORDISPLAYFDEV))
                    (SETQ OLDONOFF (fetch (DISPLAYSTATE ONOFF) of DISPLAYSTATE))
                    (SETQ OLDTYPE (fetch (DISPLAYINFO DITYPE) of DISPLAYINFO))
                    (COND
                       ((NULL TYPE)
                        (SETQ TYPE OLDTYPE]
          [COND
             ((EQ ONOFF 'ON)
              (COND
                 ((EQ OLDONOFF 'ON)                          (* Color display already on.
                                                             *)
                  (COLORDISPLAY 'OFF)
                  (COLORDISPLAY 'ON TYPE))
                 ((SETQ \COLORDISPLAYFDEV (\CREATECOLORDISPLAYFDEV TYPE))
                                                             (* Color display is off, turn it on.
                                                             *)
                  (\STARTCOLOR \COLORDISPLAYFDEV)))
              (SCREENCOLORMAP (SCREENCOLORMAP))
              (COND
                 ((OR (NULL \COLORSCREEN)
                      (NOT (EQ TYPE OLDTYPE)))
                  (SETQ \COLORSCREEN (CREATESCREEN (COLORSCREENBITMAP)))
                  (WINDOWWORLD 'ON \COLORSCREEN)
          
          (* Besides being a test pattern, SHOWCOLORTESTPATTERN changes a solid field of 
          color into a striped pattern. Some color cards have trouble holding a solid 
          field of color without variation steady.
          *)

                  (SHOWCOLORTESTPATTERN 10)))
              (SETQ BACKGROUNDCURSOREXITFN 'CURSOREXIT))
             ((EQ ONOFF 'OFF)
              (COND
                 ((NOT (EQ OLDONOFF 'OFF))                   (* Color display is on, turn it off.
                                                             *)
                  (SETQ BACKGROUNDCURSOREXITFN NIL)
                  [COND
                     ((NOT (EQ \CURSORSCREEN \MAINSCREEN))   (* Move cursor off \COLORSCREEN.
                                                             *)
                      (CURSORSCREEN \MAINSCREEN (IQUOTIENT (fetch (SCREEN SCWIDTH) of \MAINSCREEN)
                                                       2)
                             (IQUOTIENT (fetch (SCREEN SCHEIGHT) of \MAINSCREEN)
                                    2]
                  (\STOPCOLOR \COLORDISPLAYFDEV]
          (RETURN OLDONOFF])

(COLORMAPBITS
  [LAMBDA (COLORMAP)                                         (* kbr%: " 5-Jun-85 20:47")
    (INTEGERLENGTH (SUB1 (ARRAYSIZE COLORMAP])

(\CreateColorScreenBitMap
  [LAMBDA (FDEV)                                             (* ; "Edited 16-Jan-87 17:17 by gbn")
                                                             (* Creates color display bitmap 
                                                             ColorScreenBitMap for FDEV)
    (DECLARE (GLOBALVARS ColorScreenBitMap))
    (PROG (DISPLAYINFO WIDTH HEIGHT BITSPERPIXEL)
          (SETQ DISPLAYINFO (fetch (FDEV WINDOWDATA) of FDEV))
          (SETQ WIDTH (fetch (DISPLAYINFO DIWIDTH) of DISPLAYINFO))
          (SETQ HEIGHT (fetch (DISPLAYINFO DIHEIGHT) of DISPLAYINFO))
          (SETQ BITSPERPIXEL (fetch (DISPLAYINFO DIBITSPERPIXEL) of DISPLAYINFO))
          (SETQ ColorScreenBitMap (create BITMAP
                                         BITMAPBASE _ (\COLORDISPLAYBITS WIDTH HEIGHT BITSPERPIXEL)
                                         BITMAPRASTERWIDTH _ (FOLDHI (ITIMES WIDTH BITSPERPIXEL)
                                                                    BITSPERWORD)
                                         BITMAPWIDTH _ WIDTH
                                         BITMAPHEIGHT _ HEIGHT
                                         BITMAPBITSPERPIXEL _ BITSPERPIXEL))
          (RETURN ColorScreenBitMap])

(\CREATECOLORDISPLAYFDEV
  [LAMBDA (TYPE)                                             (* kbr%: "15-Feb-86 14:48")
    (PROG (DISPLAYINFO WSOPS)
          (SETQ DISPLAYINFO (ASSOC TYPE \DISPLAYINFOALIST))
          (SETQ WSOPS (fetch (DISPLAYINFO DIWSOPS) of DISPLAYINFO))
          (COND
             ((NULL DISPLAYINFO)
              (RETURN \COLORDISPLAYFDEV)))
          [COND
             ((NULL \COLORDISPLAYFDEV)
              (SETQ \COLORDISPLAYFDEV (\CREATEDISPLAY 'COLORDISPLAY]
          (replace (FDEV WINDOWDATA) of \COLORDISPLAYFDEV with DISPLAYINFO)
          (replace (FDEV EVENTFN) of \COLORDISPLAYFDEV with (fetch (WSOPS EVENTFN) of WSOPS))
          (replace (FDEV WINDOWOPS) of \COLORDISPLAYFDEV with WSOPS)
          (\CreateColorScreenBitMap \COLORDISPLAYFDEV)
          (RETURN \COLORDISPLAYFDEV])

(COLORMAP
  [LAMBDA (BITSPERPIXEL NEWCOLORMAP)                         (* kbr%: "21-Aug-85 21:06")
                                                             (* Change system colormap to 
                                                             NEWCOLORMAP returning OLDCOLORMAP *)
    (PROG (OLDCOLORMAP)
          (SETQ OLDCOLORMAP (SELECTQ BITSPERPIXEL
                                (4 \4COLORMAP)
                                (8 \8COLORMAP)
                                NIL))
          [COND
             (NEWCOLORMAP (SELECTQ BITSPERPIXEL
                              (4 (SETQ \4COLORMAP NEWCOLORMAP))
                              (8 (SETQ \8COLORMAP NEWCOLORMAP))
                              NIL)
                    (COND
                       ((AND \COLORDISPLAYFDEV (EQ (fetch (DISPLAYSTATE ONOFF)
                                                      of (fetch (FDEV DEVICEINFO) of 
                                                                                    \COLORDISPLAYFDEV
                                                                ))
                                                   'ON)
                             (EQ (BITSPERPIXEL (COLORSCREENBITMAP))
                                 BITSPERPIXEL))
                        (for I from 0 to (SUB1 (ARRAYSIZE NEWCOLORMAP))
                           do (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV I (ELT NEWCOLORMAP I]
          (RETURN OLDCOLORMAP])

(SCREENCOLORMAP
  [LAMBDA (NEWCOLORMAP)                                      (* kbr%: "21-Aug-85 21:12")
    (COLORMAP (BITSPERPIXEL (COLORSCREENBITMAP))
           NEWCOLORMAP])

(SCREENCOLORMAPENTRY
  [LAMBDA (COLOR RGB)                                        (* kbr%: " 5-Jun-86 19:40")
    (SETA (SCREENCOLORMAP)
          COLOR RGB)
    (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV COLOR RGB])

(ROTATECOLORMAP
  [LAMBDA (STARTCOLOR THRUCOLOR)                             (* kbr%: " 5-Jun-86 23:20")
    (PROG (COLORMAP RGB)
          (SETQ COLORMAP (SCREENCOLORMAP))
          (COND
             ((NULL STARTCOLOR)
              (SETQ STARTCOLOR 0)))
          [COND
             ((NULL THRUCOLOR)
              (SETQ THRUCOLOR (SUB1 (ARRAYSIZE COLORMAP]
          (SETQ RGB (ELT COLORMAP THRUCOLOR))
          (for COLOR from STARTCOLOR to THRUCOLOR do (swap RGB (ELT COLORMAP COLOR))
                                                     (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV COLOR
                                                            (ELT COLORMAP COLOR])

(RGBCOLORMAP
  [LAMBDA (REDBITS GREENBITS BLUEBITS BITSPERPIXEL)          (* kbr%: "13-Aug-85 16:49")
          
          (* creates a color map with the specified number of bits allocated per primary 
          color. Always has the RED bits on the left.)

    (PROG (NRED NGREEN NBLUE REDS GREENS BLUES COLORMAP)
          (SETQ NRED (SUB1 (EXPT 2 REDBITS)))
          (SETQ NGREEN (SUB1 (EXPT 2 GREENBITS)))
          (SETQ NBLUE (SUB1 (EXPT 2 BLUEBITS)))
          [SETQ REDS (for I from 0 to NRED collect (FIXR (FQUOTIENT (ITIMES 255 I)
                                                                NRED]
          [SETQ GREENS (for I from 0 to NGREEN collect (FIXR (FQUOTIENT (ITIMES 255 I)
                                                                    NGREEN]
          [SETQ BLUES (for I from 0 to NBLUE collect (FIXR (FQUOTIENT (ITIMES 255 I)
                                                                  NBLUE]
          (SETQ COLORMAP
           (COLORMAPCREATE [for I from 1 to (EXPT 2 (IDIFFERENCE BITSPERPIXEL (IPLUS REDBITS 
                                                                                     GREENBITS 
                                                                                     BLUEBITS)))
                              join (for RED in REDS
                                      join (for GREEN in GREENS
                                              join (for BLUE in BLUES
                                                      collect (create RGB
                                                                     RED _ RED
                                                                     GREEN _ GREEN
                                                                     BLUE _ BLUE]
                  BITSPERPIXEL))
          (RETURN COLORMAP])

(CMYCOLORMAP
  [LAMBDA (CYANBITS MAGENTABITS YELLOWBITS BITSPERPIXEL)     (* kbr%: "13-Aug-85 16:46")
    (PROG (COLORMAP MAXCOLOR)
          (SETQ COLORMAP (RGBCOLORMAP CYANBITS MAGENTABITS YELLOWBITS BITSPERPIXEL))
          (SETQ MAXCOLOR (SUB1 (ARRAYSIZE COLORMAP)))
          [for I from 0 to (IQUOTIENT MAXCOLOR 2) do (swap (ELT COLORMAP I)
                                                           (ELT COLORMAP (IDIFFERENCE MAXCOLOR I]
          (RETURN COLORMAP])

(GRAYCOLORMAP
  [LAMBDA (BITSPERPIXEL)                                     (* kbr%: "11-Jul-85 19:20")
                                                             (* creates a gray color map *)
    (PROG (MAXCOLOR GRAYS COLORMAP)
          (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL))
          [SETQ GRAYS (for I from MAXCOLOR to 0 by -1 collect (FIXR (FQUOTIENT (ITIMES 255 I)
                                                                           MAXCOLOR]
          (SETQ COLORMAP (COLORMAPCREATE (for GRAY in GRAYS
                                            collect (create RGB
                                                           RED _ GRAY
                                                           GREEN _ GRAY
                                                           BLUE _ GRAY))
                                BITSPERPIXEL))
          (RETURN COLORMAP])

(COLORSCREENBITMAP
  [LAMBDA NIL                                                (* rrb "22-OCT-82 14:01")
                                                             (* returns the color screen bitmap)
    ColorScreenBitMap])

(\COLORDISPLAYBITS
  [LAMBDA (WIDTH HEIGHT BITSPERPIXEL)                        (* kbr%: "18-Aug-85 17:09")
          
          (* returns a pointer to the bits that the color board needs.)

    (DECLARE (GLOBALVARS \COLORDISPLAYBITS))
    (PROG (NPAGES)
          
          (* TBW%: If you come through this function a second time with different screen 
          params won't you get screwed half the time? *)

          [COND
             ((NULL \COLORDISPLAYBITS)                       (* 2 extra pages needed for 
                                                             DORADOCOLOR microcode bug.
                                                             *)
              (SETQ NPAGES (IPLUS (FOLDHI (ITIMES (FOLDHI (ITIMES WIDTH BITSPERPIXEL)
                                                         BITSPERWORD)
                                                 HEIGHT)
                                         WORDSPERPAGE)
                                  2))
          
          (* \ALLOCBLOCK can't hack bitmaps of the size of the 1132 color screen)

              (SETQ \COLORDISPLAYBITS (COND
                                         ((IGREATERP (UNFOLD NPAGES CELLSPERPAGE)
                                                 \MaxArrayNCells)
                                          (OR (\ALLOCPAGEBLOCK NPAGES)
                                              (ERROR "No room for color screen of size" NPAGES)))
                                         (T (\ALLOCBLOCK (UNFOLD NPAGES CELLSPERPAGE)
                                                   NIL NIL CELLSPERPAGE]
          (RETURN \COLORDISPLAYBITS])

(COLORSCREEN
  [LAMBDA NIL                                                (* kbr%: " 2-Feb-86 15:02")
    \COLORSCREEN])

(SHOWCOLORTESTPATTERN
  [LAMBDA (SIZE)                                             (* kbr%: "15-Feb-86 15:16")
          
          (* Put a color test pattern on the color display.
          SIZE is the size of the stripes that will be put up.
          *)

    (PROG (DESTINATION WIDTH HEIGHT BITSPERPIXEL COLORS NCOLORS)
          (OR (NUMBERP SIZE)
              (SETQ SIZE 10))
          (SETQ DESTINATION (COLORSCREENBITMAP))
          (SETQ WIDTH (BITMAPWIDTH DESTINATION))
          (SETQ HEIGHT (BITMAPHEIGHT DESTINATION))
          (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION))
          (BLTSHADE MINIMUMSHADE DESTINATION)
          (SETQ COLORS (for BUCKET in COLORNAMES collect (CAR BUCKET)))
          (SETQ NCOLORS (LENGTH COLORS))
          (for COLOR from 0 as LEFT from 10 by 80 to WIDTH
             do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD COLOR NCOLORS]
                       DESTINATION LEFT 410 60 60))
          (for COLOR from 1 as LEFT from 10 by 80 to WIDTH
             do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD COLOR NCOLORS]
                       DESTINATION LEFT 330 60 60))
          (for HORIZCOLOR from 0 as BOTTOM from 0 to 300 by SIZE
             do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD HORIZCOLOR NCOLORS]
                       DESTINATION 0 BOTTOM WIDTH SIZE 'REPLACE)
             finally (for VERTCOLOR from 0 as LEFT from 0 to WIDTH by (ITIMES SIZE 2)
                        do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD VERTCOLOR NCOLORS]
                                  DESTINATION LEFT 0 SIZE BOTTOM 'REPLACE])
)

(RPAQ? COLORMONITORTYPE 'CONRAC)
(DEFINEQ

(\STARTCOLOR
  [LAMBDA (FDEV)                                             (* kbr%: " 1-Jul-85 13:41")
    (WSOP 'STARTCOLOR FDEV])

(\STOPCOLOR
  [LAMBDA (FDEV)                                             (* kbr%: " 1-Jul-85 13:40")
    (WSOP 'STOPCOLOR FDEV])

(\SENDCOLORMAPENTRY
  [LAMBDA (FDEV COLOR# RGB)                                  (* kbr%: " 1-Jul-85 19:43")
                                                             (* changes the window world background 
                                                             to SHADE)
    (WSOP 'SENDCOLORMAPENTRY FDEV COLOR# RGB])
)
(DEFINEQ

(COLORMAPCREATE
  [LAMBDA (INTENSITIES BITSPERPIXEL)                         (* ; "Edited 16-Jan-87 17:36 by gbn")
    (PROG (COLORMAP)
          (SELECTQ BITSPERPIXEL
              (4 [COND
                    ((NULL INTENSITIES)
                     (SETQ COLORMAP (CMYCOLORMAP 2 1 1 BITSPERPIXEL)))
                    (T (SETQ COLORMAP (ARRAY 16 NIL NIL 0))
                       (for COLOR from 0 to 15 as RGB in INTENSITIES
                          do (SETA COLORMAP COLOR RGB])
              (8 [COND
                    ((NULL INTENSITIES)
                     (SETQ COLORMAP (CMYCOLORMAP 3 3 2 BITSPERPIXEL)))
                    (T (SETQ COLORMAP (ARRAY 256 NIL NIL 0))
                       (for COLOR from 0 to 255 as RGB in INTENSITIES
                          do (SETA COLORMAP COLOR RGB])
              (24 (SETQ COLORMAP NIL))
              (\ILLEGAL.ARG BITSPERPIXEL))
          (RETURN COLORMAP])

(COLORLEVEL
  [LAMBDA (COLOR PRIMARY NEWLEVEL)                           (* kbr%: " 5-Jun-86 19:58")
    (PROG (RGB OLDVALUE)
          (SETQ RGB (ELT (SCREENCOLORMAP)
                         COLOR))
          (SETQ OLDVALUE (SELECTQ PRIMARY
                             (RED (fetch (RGB RED) of RGB))
                             (GREEN (fetch (RGB GREEN) of RGB))
                             (BLUE (fetch (RGB BLUE) of RGB))
                             (\ILLEGAL.ARG PRIMARY)))
          (COND
             (NEWLEVEL (SELECTQ PRIMARY
                           (RED (replace (RGB RED) of RGB with NEWLEVEL))
                           (GREEN (replace (RGB GREEN) of RGB with NEWLEVEL))
                           (BLUE (replace (RGB BLUE) of RGB with NEWLEVEL))
                           (SHOULDNT))
                    (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV COLOR RGB)))
          (RETURN OLDVALUE])

(COLORNUMBERP
  [LAMBDA (COLOR# BITSPERPIXEL NOERRFLG)                     (* kbr%: "21-Aug-85 21:22")
                                                             (* returns the color number from a 
                                                             color.)
    (PROG (RGB)
          (COND
             [(FIXP COLOR#)
              (RETURN (COND
                         ((AND (IGEQ COLOR# 0)
                               (ILEQ COLOR# (MAXIMUMCOLOR BITSPERPIXEL))
                               COLOR#))
                         (NOERRFLG NIL)
                         (T (\ILLEGAL.ARG COLOR#]
             [(LITATOM COLOR#)
              (RETURN (COND
                         ((SETQ RGB (\LOOKUPCOLORNAME COLOR#))
                                                             (* recursively look up color number)
                          (COLORNUMBERP (CDR RGB)
                                 BITSPERPIXEL NOERRFLG))
                         (NOERRFLG NIL)
                         (T (ERROR "Unknown color name" COLOR#]
             ((HLSP COLOR#)                                  (* HLS form convert to RGB)
              (SETQ RGB (HLSTORGB COLOR#)))
             ((RGBP COLOR#)                                  (* check for RGB or HLS)
              (SETQ RGB COLOR#))
             (NOERRFLG (RETURN NIL))
             (T (\ILLEGAL.ARG COLOR#)))
          (RETURN (COND
                     ((COLORFROMRGB RGB BITSPERPIXEL))
                     (NOERRFLG NIL)
                     (T (ERROR COLOR# "not available in color map"])

(COLORFROMRGB
  [LAMBDA (RGB BITSPERPIXEL)                                 (* kbr%: "15-Feb-86 11:16")
          
          (* looks in the colormap for a color that has RGB levels)

    (PROG (COLOR COLORMAP)
          (COND
             ((EQ BITSPERPIXEL 24)                           (* Assuming subtractive system in 
                                                             which white=0. *)
              [SETQ COLOR (LOGOR (LLSH (IDIFFERENCE 255 (fetch (RGB RED) of RGB))
                                       16)
                                 (LLSH (IDIFFERENCE 255 (fetch (RGB GREEN) of RGB))
                                       8)
                                 (IDIFFERENCE 255 (fetch (RGB BLUE) of RGB]
              (RETURN COLOR)))
          (SETQ COLORMAP (COLORMAP BITSPERPIXEL))
          (SETQ COLOR (for COLOR from 0 to (SUB1 (ARRAYSIZE COLORMAP))
                         thereis (EQUAL (ELT COLORMAP COLOR)
                                        RGB)))
          (RETURN COLOR])

(INTENSITIESFROMCOLORMAP
  [LAMBDA (COLORMAP)                                         (* kbr%: "21-Aug-85 21:17")
          
          (* returns the intensity levels of the primary colors from a colormap.
          This list can be passed into COLORMAPCREATE to get an equivalent colormap.)

    (for I from 0 to (SUB1 (ARRAYSIZE COLORMAP)) collect (ELT COLORMAP I])

(SETCOLORINTENSITY
  [LAMBDA (COLORMAP COLOR# INTENSITIES)                      (* rrb "13-DEC-82 13:15")
          
          (* sets the intensity levels of a color number in a color map.
          Does not return the previous setting.)

    (PROG (RGB)
          (SETQ RGB INTENSITIES)
      LP  (COND
             [(NULL RGB)
              (SETQ RGB '(0 0 0]
             ((RGBP RGB))
             ((HLSP RGB)
              (SETQ RGB (HLSTORGB RGB)))
             ((SETQ RGB (CDR (\LOOKUPCOLORNAME RGB)))
              (GO LP))
             (T (\ILLEGAL.ARG RGB)))
          (COLORLEVEL COLORMAP COLOR# 'RED (fetch (RGB RED) of RGB))
          (COLORLEVEL COLORMAP COLOR# 'GREEN (fetch (RGB GREEN) of RGB))
          (COLORLEVEL COLORMAP COLOR# 'BLUE (fetch (RGB BLUE) of RGB])
)
(DEFINEQ

(\FAST8BIT
  [LAMBDA (A B N MAP)                                        (* edited%: "10-SEP-82 16:14")
    (bind AW (I _ 0) for J from 0 do (SETQ AW (\ADDBASE A J))
                                     (OR (IGREATERP N I)
                                         (RETURN))
                                     (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN1) of AW)))
                                     (OR (IGREATERP N (add I 1))
                                         (RETURN))
                                     (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN2) of AW)))
                                     (OR (IGREATERP N (add I 1))
                                         (RETURN))
                                     (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN3) of AW)))
                                     (OR (IGREATERP N (add I 1))
                                         (RETURN))
                                     (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN4) of AW)))
                                     (OR (IGREATERP N (add I 1))
                                         (RETURN))
                                     (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN5) of AW)))
                                     (OR (IGREATERP N (add I 1))
                                         (RETURN))
                                     (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN6) of AW)))
                                     (OR (IGREATERP N (add I 1))
                                         (RETURN))
                                     (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN7) of AW)))
                                     (OR (IGREATERP N (add I 1))
                                         (RETURN))
                                     (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN8) of AW)))
                                     (add I 1])

(\MAP4
  [LAMBDA (|0C| |1C|)                                        (* edited%: "10-SEP-82 15:50")
    (SETQ |0C| (COND
                  (|0C| (COLORNUMBERP |0C| 4))
                  (T 0)))                                    (* Mask out but 4 bits)
    (SETQ |1C| (COND
                  (|1C| (COLORNUMBERP |1C| 4))
                  (T 15)))
    (PROG (MAP)
          (SETQ MAP (ARRAY 16 'SMALLPOSP 0 0))
          [for I from 0 to 15
             do (SETA MAP I (for J from 0 to 3 sum (LLSH (COND
                                                            ((ZEROP (LOGAND I (LLSH 1 J)))
                                                             |0C|)
                                                            (T |1C|))
                                                         (ITIMES J 4]
          (RETURN MAP])

(\MAP8
  [LAMBDA (|0C| |1C|)                                        (* edited%: "10-SEP-82 15:50")
          
          (* returns an array of words that contain the destination bitmap should contain 
          if a black and white bitmap is blown up to an 8 bit per pixel bitmap.)

    (SETQ |0C| (COND
                  (|0C| (COLORNUMBERP |0C| 8))
                  (T 0)))                                    (* make sure color numbers are given.)
    (SETQ |1C| (COND
                  (|1C| (COLORNUMBERP |1C| 8))
                  (T 255)))
    (PROG (MAP)
          (SETQ MAP (ARRAY 4 'SMALLPOSP 0 0))
          [for I from 0 to 3 do (SETA MAP I (LOGOR (COND
                                                      ((ZEROP (LOGAND I 1))
                                                       |0C|)
                                                      (T |1C|))
                                                   (LLSH (COND
                                                            ((ZEROP (LOGAND I 2))
                                                             |0C|)
                                                            (T |1C|))
                                                         8]
          (RETURN MAP])
)
(DEFINEQ

(\GETCOLORBRUSH
  [LAMBDA (BRUSH COLOR NBITS)                                (* rrb "21-DEC-82 20:46")
          
          (* produces a colorbitmap that is 1's where ever the brush bitmap would be 1)

    (COND
       ((AND (BITMAPP BRUSH)
             (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BRUSH)
                 NBITS))
        BRUSH)
       (T (COLORIZEBITMAP [COND
                             ((LISTP BRUSH)
                              (\BRUSHBITMAP (fetch (BRUSH BRUSHSHAPE) of BRUSH)
                                     (fetch (BRUSH BRUSHSIZE) of BRUSH)))
                             (T (\BRUSHBITMAP 'ROUND (OR BRUSH 1]
                 0 COLOR NBITS])
)
(DEFINEQ

(\DRAWCOLORLINE1
  [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH NBITS COLOR)
                                                             (* rrb "10-OCT-82 12:33")
    (DECLARE (LOCALVARS . T))
    (COND
       ((EQ NBITS 4)
        (\DRAW4BPPCOLORLINE X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR))
       (T (\DRAW8BPPCOLORLINE X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR])

(\DRAW4BPPCOLORLINE
  [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR)
                                                             (* kbr%: "22-Jul-85 09:16")
    (DECLARE (LOCALVARS . T))
          
          (* draws a color 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.)

    (PROG (MAPPTR MASK COLORMASK COLORMASKORG WORDOFFSET)
          (SETQ COLORMASKORG (LLSH COLOR 12))
          
          (* keep word offset from bitmapbase so that the YINC can be negative or 
          positive. Used to use \ADDBASE directly but negative case was not in micro code 
          and ran much slower.)

          [SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH)
                                  (FOLDLO X0 (CONSTANT (LRSH BITSPERWORD 2]
          (SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET))
          (SETQ MASK (\4BITMASK X0))
          (SETQ COLORMASK (LLSH COLOR (LLSH (IDIFFERENCE 3 (LOGAND X0 3))
                                            2)))
          (SETQ X0 0)
          (SETQ Y0 0)
          (COND
             ((IGEQ DX DY)                                   (* X is the fastest mover.)
              (.DRAW4BPPLINEX. MODE))
             (T                                              (* Y is the fastest mover.)
                (.DRAW4BPPLINEY. MODE])

(\DRAW8BPPCOLORLINE
  [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR)
                                                             (* kbr%: "22-Jul-85 09:18")
    (DECLARE (LOCALVARS . T))
          
          (* draws a color 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.)

    (PROG (MAPPTR STARTBYTE WORDOFFSET)
          
          (* keep word offset from bitmapbase so that the YINC can be negative or 
          positive. Used to use \ADDBASE directly but negative case was not in micro code 
          and ran much slower.)

          [SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH)
                                  (FOLDLO X0 (CONSTANT (LRSH BITSPERWORD 3]
          (SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET))
          (SETQ STARTBYTE (LOGAND X0 1))
          (SETQ X0 0)
          (SETQ Y0 0)
          (COND
             ((IGEQ DX DY)                                   (* X is the fastest mover.)
              (.DRAW8BPPLINEX MODE))
             (T                                              (* Y is the fastest mover.)
                (.DRAW8BPPLINEY MODE])

(\DRAW24BPPCOLORLINE
  [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR)
                                                             (* kbr%: "15-Feb-86 23:00")
    (DECLARE (LOCALVARS . T))
          
          (* draws a color 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.)

    (PROG (MAPPTR STARTBYTE WORDOFFSET)
          
          (* keep word offset from bitmapbase so that the YINC can be negative or 
          positive. Used to use \ADDBASE directly but negative case was not in micro code 
          and ran much slower.)

          [SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH)
                                  (FOLDLO X0 (CONSTANT (LRSH BITSPERWORD 3]
          (SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET))
          (SETQ STARTBYTE (LOGAND X0 1))
          (SETQ X0 0)
          (SETQ Y0 0)
          (COND
             ((IGEQ DX DY)                                   (* X is the fastest mover.)
              (.DRAW24BPPLINEX MODE))
             (T                                              (* Y is the fastest mover.)
                (.DRAW24BPPLINEY MODE])
)
(DECLARE%: DONTCOPY DOEVAL@COMPILE 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS .DRAW4BPPLINEX. MACRO
          [(MODE)
           (PROG (INSIDEBITS OUTSIDEBITS)
                 (until (IGREATERP X0 XLIMIT)
                    do                                   (* main loop)
                          (SETQ INSIDEBITS (LOGAND MASK (fetch (BITMAPWORD BITS) of MAPPTR)))
                          (SETQ OUTSIDEBITS (LOGAND (LOGNOT MASK)
                                                   (fetch (BITMAPWORD BITS) of MAPPTR)))
                          [replace (BITMAPWORD BITS) of MAPPTR
                             with (SELECTQ MODE
                                          (ERASE (LOGOR (LOGAND COLORMASK INSIDEBITS)
                                                        OUTSIDEBITS))
                                          (INVERT (LOGOR (LOGXOR COLORMASK INSIDEBITS)
                                                         OUTSIDEBITS))
                                          (PAINT (LOGOR (LOGOR COLORMASK INSIDEBITS)
                                                        OUTSIDEBITS))
                                          (PROGN             (* case is REPLACE.
                                                           Legality of OPERATION has been 
                                                           checked by \CLIPANDDRAWLINE1)
                                                 (LOGOR COLORMASK OUTSIDEBITS]
                          [COND
                             ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
                              (COND
                                 ((IGREATERP (SETQ Y0 (ADD1 Y0))
                                         YLIMIT)
                                  (RETURN)))
                              (SETQ CDL (IDIFFERENCE CDL DX))
                              (SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET 
                                                                                        YINC]
                          [COND
                             [(ZEROP (SETQ MASK (LRSH MASK 4)))
                                                             (* crossed word boundary)
                              [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET]
                              (SETQ COLORMASK COLORMASKORG)
                              (SETQ MASK (CONSTANT (\4BITMASK 0]
                             (T (SETQ COLORMASK (LRSH COLORMASK 4]
                          (SETQ X0 (ADD1 X0])

(PUTPROPS .DRAW8BPPLINEX MACRO ((MODE)
                                        (PROG NIL
                                              (COND
                                                 ((EQ STARTBYTE 1)
                                                  (GO 1LP)))
                                          0LP                (* main loop)
                                              (\PUTBASEBYTE MAPPTR 0
                                                     (SELECTQ MODE
                                                         (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0)
                                                                       ))
                                                         (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 0
                                                                                      )))
                                                         (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0)))
                                                         (PROGN 
                                                             (* case is REPLACE.
                                                           Legality of OPERATION has been 
                                                           checked by \CLIPANDDRAWLINE1)
                                                                COLOR)))
                                              [COND
                                                 ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
                                                  (COND
                                                     ((IGREATERP (SETQ Y0 (ADD1 Y0))
                                                             YLIMIT)
                                                      (RETURN)))
                                                  (SETQ CDL (IDIFFERENCE CDL DX))
                                                  (SETQ MAPPTR (\ADDBASE BITMAPBASE
                                                                      (SETQ WORDOFFSET
                                                                       (IPLUS WORDOFFSET YINC]
                                              (COND
                                                 ((IGREATERP (SETQ X0 (ADD1 X0))
                                                         XLIMIT)
                                                  (RETURN)))
                                          1LP (\PUTBASEBYTE MAPPTR 1
                                                     (SELECTQ MODE
                                                         (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 1)
                                                                       ))
                                                         (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 1
                                                                                      )))
                                                         (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1)))
                                                         (PROGN 
                                                             (* case is REPLACE.
                                                           Legality of OPERATION has been 
                                                           checked by \CLIPANDDRAWLINE1)
                                                                COLOR)))
                                              [COND
                                                 ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
                                                  (COND
                                                     ((IGREATERP (SETQ Y0 (ADD1 Y0))
                                                             YLIMIT)
                                                      (RETURN)))
                                                  (SETQ CDL (IDIFFERENCE CDL DX))
                                                  (SETQ MAPPTR (\ADDBASE BITMAPBASE
                                                                      (SETQ WORDOFFSET
                                                                       (IPLUS WORDOFFSET YINC]
                                              (COND
                                                 ((IGREATERP (SETQ X0 (ADD1 X0))
                                                         XLIMIT)
                                                  (RETURN)))
                                              [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
                                                                                 (ADD1 WORDOFFSET]
                                              (GO 0LP))))

(PUTPROPS .DRAW24BPPLINEX MACRO ((MODE)
                                         (PROG NIL           (* main loop)
                                           LP  (\PUTBASE24 MAPPTR 0
                                                      (SELECTQ MODE
                                                          (ERASE (LOGAND COLOR (\GETBASE24 MAPPTR
                                                                                      0)))
                                                          (INVERT (LOGXOR COLOR (\GETBASE24
                                                                                 MAPPTR 0)))
                                                          (PAINT (LOGOR COLOR (\GETBASE24 MAPPTR
                                                                                     0)))
                                                          (PROGN 
                                                             (* case is REPLACE.
                                                           Legality of OPERATION has been 
                                                           checked by \CLIPANDDRAWLINE1)
                                                                 COLOR)))
                                               [COND
                                                  ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY]
                                                   (COND
                                                      ((IGREATERP (SETQ Y0 (ADD1 Y0))
                                                              YLIMIT)
                                                       (RETURN)))
                                                   (SETQ CDL (IDIFFERENCE CDL DX))
                                                   (SETQ MAPPTR (\ADDBASE BITMAPBASE
                                                                       (SETQ WORDOFFSET
                                                                        (IPLUS WORDOFFSET YINC]
                                               (COND
                                                  ((IGREATERP (SETQ X0 (ADD1 X0))
                                                          XLIMIT)
                                                   (RETURN)))
                                               [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
                                                                                  (ADD1 WORDOFFSET]
                                               (GO LP))))

(PUTPROPS .DRAW4BPPLINEY. MACRO
          [(MODE)
           (PROG (INSIDEBITS OUTSIDEBITS)
                 (until (IGREATERP Y0 YLIMIT)
                    do                                   (* main loop)
                          (SETQ INSIDEBITS (LOGAND MASK (fetch (BITMAPWORD BITS) of MAPPTR)))
                          (SETQ OUTSIDEBITS (LOGAND (LOGNOT MASK)
                                                   (fetch (BITMAPWORD BITS) of MAPPTR)))
                          [replace (BITMAPWORD BITS) of MAPPTR
                             with (SELECTQ MODE
                                          (ERASE (LOGOR (LOGAND COLORMASK INSIDEBITS)
                                                        OUTSIDEBITS))
                                          (INVERT (LOGOR (LOGXOR COLORMASK INSIDEBITS)
                                                         OUTSIDEBITS))
                                          (PAINT (LOGOR (LOGOR COLORMASK INSIDEBITS)
                                                        OUTSIDEBITS))
                                          (PROGN             (* case is REPLACE.
                                                           Legality of OPERATION has been 
                                                           checked by \CLIPANDDRAWLINE1)
                                                 (LOGOR COLORMASK OUTSIDEBITS]
                          [COND
                             ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
                              (COND
                                 ((IGREATERP (SETQ X0 (ADD1 X0))
                                         XLIMIT)
                                  (RETURN)))
                              (SETQ CDL (IDIFFERENCE CDL DY))
                              (COND
                                 [(ZEROP (SETQ MASK (LRSH MASK 4)))
                                                             (* crossed word boundary)
                                  [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET
                                                                                           ]
                                  (SETQ COLORMASK COLORMASKORG)
                                  (SETQ MASK (CONSTANT (\4BITMASK 0]
                                 (T (SETQ COLORMASK (LRSH COLORMASK 4]
                          [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC]
                          (SETQ Y0 (ADD1 Y0])

(PUTPROPS .DRAW8BPPLINEY MACRO ((MODE)
                                        (PROG NIL
                                              (COND
                                                 ((EQ STARTBYTE 1)
                                                  (GO 1LP)))
                                          0LP                (* main loop)
                                              (\PUTBASEBYTE MAPPTR 0
                                                     (SELECTQ MODE
                                                         (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0)
                                                                       ))
                                                         (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 0
                                                                                      )))
                                                         (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0)))
                                                         (PROGN 
                                                             (* case is REPLACE.
                                                           Legality of OPERATION has been 
                                                           checked by \CLIPANDDRAWLINE1)
                                                                COLOR)))
                                              (COND
                                                 ((IGREATERP (SETQ Y0 (ADD1 Y0))
                                                         YLIMIT)
                                                  (RETURN)))
                                              [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
                                                                                 (IPLUS WORDOFFSET 
                                                                                        YINC]
                                              (COND
                                                 ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
                                                             (* moved enough in Y to move a point 
                                                           in X)
                                                  (COND
                                                     ((IGREATERP (SETQ X0 (ADD1 X0))
                                                             XLIMIT)
                                                      (RETURN)))
                                                  (SETQ CDL (IDIFFERENCE CDL DY))
                                                  (GO 1LP)))
                                              (GO 0LP)
                                          1LP (\PUTBASEBYTE MAPPTR 1
                                                     (SELECTQ MODE
                                                         (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 1)
                                                                       ))
                                                         (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 1
                                                                                      )))
                                                         (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1)))
                                                         (PROGN 
                                                             (* case is REPLACE.
                                                           Legality of OPERATION has been 
                                                           checked by \CLIPANDDRAWLINE1)
                                                                COLOR)))
                                              (COND
                                                 ((IGREATERP (SETQ Y0 (ADD1 Y0))
                                                         YLIMIT)
                                                  (RETURN)))
                                              [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
                                                                                 (IPLUS WORDOFFSET 
                                                                                        YINC]
                                              (COND
                                                 ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
                                                             (* moved enough in Y to move a point 
                                                           in X)
                                                  (COND
                                                     ((IGREATERP (SETQ X0 (ADD1 X0))
                                                             XLIMIT)
                                                      (RETURN)))
                                                  (SETQ CDL (IDIFFERENCE CDL DY))
                                                  [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
                                                                                     (ADD1 WORDOFFSET
                                                                                           ]
                                                  (GO 0LP)))
                                              (GO 1LP))))

(PUTPROPS .DRAW24BPPLINEY MACRO ((MODE)
                                         (PROG NIL
                                               (COND
                                                  ((EQ STARTBYTE 1)
                                                   (GO 1LP)))
                                           0LP               (* main loop)
                                               (\PUTBASEBYTE MAPPTR 0
                                                      (SELECTQ MODE
                                                          (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0
                                                                                      )))
                                                          (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR
                                                                                       0)))
                                                          (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0)
                                                                        ))
                                                          (PROGN 
                                                             (* case is REPLACE.
                                                           Legality of OPERATION has been 
                                                           checked by \CLIPANDDRAWLINE1)
                                                                 COLOR)))
                                               (COND
                                                  ((IGREATERP (SETQ Y0 (ADD1 Y0))
                                                          YLIMIT)
                                                   (RETURN)))
                                               [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
                                                                                  (IPLUS WORDOFFSET 
                                                                                         YINC]
                                               (COND
                                                  ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
                                                             (* moved enough in Y to move a point 
                                                           in X)
                                                   (COND
                                                      ((IGREATERP (SETQ X0 (ADD1 X0))
                                                              XLIMIT)
                                                       (RETURN)))
                                                   (SETQ CDL (IDIFFERENCE CDL DY))
                                                   (GO 1LP)))
                                               (GO 0LP)
                                           1LP (\PUTBASEBYTE MAPPTR 1
                                                      (SELECTQ MODE
                                                          (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 1
                                                                                      )))
                                                          (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR
                                                                                       1)))
                                                          (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1)
                                                                        ))
                                                          (PROGN 
                                                             (* case is REPLACE.
                                                           Legality of OPERATION has been 
                                                           checked by \CLIPANDDRAWLINE1)
                                                                 COLOR)))
                                               (COND
                                                  ((IGREATERP (SETQ Y0 (ADD1 Y0))
                                                          YLIMIT)
                                                   (RETURN)))
                                               [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
                                                                                  (IPLUS WORDOFFSET 
                                                                                         YINC]
                                               (COND
                                                  ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX]
                                                             (* moved enough in Y to move a point 
                                                           in X)
                                                   (COND
                                                      ((IGREATERP (SETQ X0 (ADD1 X0))
                                                              XLIMIT)
                                                       (RETURN)))
                                                   (SETQ CDL (IDIFFERENCE CDL DY))
                                                   [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET
                                                                                      (ADD1 
                                                                                           WORDOFFSET
                                                                                            ]
                                                   (GO 0LP)))
                                               (GO 1LP))))
)
)
(DEFINEQ

(\BWTOCOLORBLT
  [LAMBDA (SOURCEBWBM SLEFT SBOTTOM DESTCOLORBM DLEFT DBOTTOM WIDTH HEIGHT 0COLOR 1COLOR DESTNBITS)
                                                             (* kbr%: "15-Feb-86 11:06")
          
          (* blits from a black and white bitmap into a color bitmap which has DESTNBITS 
          bits per pixel. DESTCOLORBM is a pointer to the color bitmap.)
                                                             (* assumes all datatypes and bounds 
                                                             have been checked)
    (SELECTQ DESTNBITS
        (4 [PROG (MAP SRCBASE SRCHEIGHT SRCRW SRCWRD SRCOFFSET DESBASE DESHEIGHT DESRW DESWRD DESOFF 
                      NBITS DESALIGNLEFT SCR)
                 (SETQ MAP (fetch (ARRAYP BASE) of (\MAP4 0COLOR 1COLOR)))
                 (SETQ SRCBASE (fetch (BITMAP BITMAPBASE) of SOURCEBWBM))
                 (SETQ SRCHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SOURCEBWBM))
                 (SETQ SRCRW (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBWBM))
                 (SETQ SRCWRD (FOLDLO SLEFT BITSPERWORD))
                 (SETQ SRCOFFSET (MOD SLEFT BITSPERWORD))
                 (SETQ DESBASE (fetch (BITMAP BITMAPBASE) of DESTCOLORBM))
                 (SETQ DESHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTCOLORBM))
                 (SETQ DESRW (fetch (BITMAP BITMAPRASTERWIDTH) of DESTCOLORBM))
                 (SETQ DESWRD (FOLDLO DLEFT 4))
                 (SETQ DESOFF (MOD DLEFT 4))
                 (SETQ NBITS 4)
          
          (* DESTCOLORBM is used to allow one bit per pixel bitblt operations on the 
          bitmap.)

                 [COND
                    ((NOT (EQ 0 DESOFF))
          
          (* save the left bits of the destination bitmap so it can be word aligned.)

                     (SETQ SCR (BITMAPCREATE 4 HEIGHT 4))
                     (BITBLT DESTCOLORBM (SETQ DESALIGNLEFT (LLSH DESWRD 2))
                            DBOTTOM SCR 0 0 DESOFF HEIGHT 'INPUT 'REPLACE]
                 (for LINECOUNTER from 1 to HEIGHT
                    do 
          
          (* linecounter goes from 1 to height because bitmaps are stored internally with 
          top first so subtracting height is necessary to get offset of line and the 1 
          corrects for height difference.)

                       (\4BITLINEBLT (\ADDBASE SRCBASE (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT
                                                                             (IPLUS LINECOUNTER 
                                                                                    SBOTTOM))
                                                                     SRCRW)
                                                              SRCWRD))
                              SRCOFFSET
                              (\ADDBASE DESBASE (IPLUS (ITIMES (IDIFFERENCE DESHEIGHT
                                                                      (IPLUS LINECOUNTER DBOTTOM))
                                                              DESRW)
                                                       DESWRD))
                              WIDTH MAP 0COLOR 1COLOR))
                 (COND
                    (DESALIGNLEFT 
          
          (* move the color bits to the right and restore the saved color bits.)

                           (BITBLT DESTCOLORBM DESALIGNLEFT DBOTTOM DESTCOLORBM (IPLUS DESALIGNLEFT 
                                                                                       DESOFF)
                                  DBOTTOM WIDTH HEIGHT 'INPUT 'REPLACE)
                           (BITBLT SCR 0 0 DESTCOLORBM DESALIGNLEFT DBOTTOM DESOFF HEIGHT
                                  'INPUT
                                  'REPLACE])
        (8 (PROG (MAP SRCBASE SRCHEIGHT SRCRW SRCWRD SRCOFFSET DESBASE DESHEIGHT DESRW DESWRD DESOFF)
                 (SETQ MAP (fetch (ARRAYP BASE) of (\MAP8 0COLOR 1COLOR)))
                 (SETQ SRCBASE (fetch (BITMAP BITMAPBASE) of SOURCEBWBM))
                 (SETQ SRCHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SOURCEBWBM))
                 (SETQ SRCRW (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBWBM))
                 (SETQ SRCWRD (FOLDLO SLEFT BITSPERWORD))
                 (SETQ SRCOFFSET (MOD SLEFT BITSPERWORD))
                 (SETQ DESBASE (fetch (BITMAP BITMAPBASE) of DESTCOLORBM))
                 (SETQ DESHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTCOLORBM))
                 (SETQ DESRW (fetch (BITMAP BITMAPRASTERWIDTH) of DESTCOLORBM))
                 (SETQ DESWRD (FOLDLO DLEFT 2))
                 (SETQ DESOFF (MOD DLEFT 2))
                 (for LINECOUNTER from 1 to HEIGHT
                    do 
          
          (* linecounter goes from 1 to height because bitmaps are stored internally with 
          top first so subtracting height is necessary to get offset of line and the 1 
          corrects for height difference.)

                       (\8BITLINEBLT (\ADDBASE SRCBASE (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT
                                                                             (IPLUS LINECOUNTER 
                                                                                    SBOTTOM))
                                                                     SRCRW)
                                                              SRCWRD))
                              SRCOFFSET
                              (\ADDBASE DESBASE (IPLUS (ITIMES (IDIFFERENCE DESHEIGHT
                                                                      (IPLUS LINECOUNTER DBOTTOM))
                                                              DESRW)
                                                       DESWRD))
                              DESOFF WIDTH MAP 0COLOR 1COLOR))))
        (24 (PROG (SRCBASE SRCHEIGHT SRCRW DESBASE DESHEIGHT DESRW)
                  (SETQ SRCBASE (fetch (BITMAP BITMAPBASE) of SOURCEBWBM))
                  (SETQ SRCHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SOURCEBWBM))
                  (SETQ SRCRW (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBWBM))
                  (SETQ DESBASE (fetch (BITMAP BITMAPBASE) of DESTCOLORBM))
                  (SETQ DESHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTCOLORBM))
                  (SETQ DESRW (fetch (BITMAP BITMAPRASTERWIDTH) of DESTCOLORBM))
                  (for LINECOUNTER from 1 to HEIGHT
                     do 
          
          (* linecounter goes from 1 to height because bitmaps are stored internally with 
          top first so subtracting height is necessary to get offset of line and the 1 
          corrects for height difference.)

                        (\24BITLINEBLT (\ADDBASE SRCBASE (ITIMES (IDIFFERENCE SRCHEIGHT
                                                                        (IPLUS LINECOUNTER SBOTTOM))
                                                                SRCRW))
                               SLEFT
                               (\ADDBASE DESBASE (ITIMES (IDIFFERENCE DESHEIGHT (IPLUS LINECOUNTER 
                                                                                       DBOTTOM))
                                                        DESRW))
                               DLEFT WIDTH 0COLOR 1COLOR))))
        (SHOULDNT])

(\4BITLINEBLT
  [LAMBDA (SBASE SBITOFFSET DBASE WIDTH MAPBASE 0COLOR 1COLOR)
                                                             (* rrb "15-OCT-82 09:28")
          
          (* moves one line of a black and white bitmap into a color bitmap using a 
          mapping table. Destination bit offset is assumed to be 0 because \BWTOCOLORBLT 
          arranges things so that it is.)

    (SELECTQ (MOD SBITOFFSET 4)
        (0                                                   (* case of moving even aligned bits.)
           [PROG NIL
             ONEWRDLP
                                                             (* SBITOFFSET is either 0, 4, 8 or 12)
                 (COND
                    ((AND (EQ SBITOFFSET 0)
                          (IGREATERP WIDTH (SUB1 BITSPERWORD)))
                                                             (* go to center loop.)
                     (GO LP))
                    ((IGREATERP 4 WIDTH)
                     [PROG (SWORDCONTENTS)
                           (SETQ SWORDCONTENTS (\GETBASE SBASE 0))
                           (SELECTQ WIDTH
                               (0)
                               (1 (PUTBASEBYTE DBASE 0 (LOGOR (LOGAND (\GETBASEBYTE DBASE 0)
                                                                     15)
                                                              (LLSH (COND
                                                                       ((ZEROP (LOGAND SWORDCONTENTS
                                                                                      (\BITMASK
                                                                                       SBITOFFSET)))
                                                                        0COLOR)
                                                                       (T 1COLOR))
                                                                    4))))
                               (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
                                                                       ((ZEROP (LOGAND SWORDCONTENTS
                                                                                      (\BITMASK
                                                                                       SBITOFFSET)))
                                                                        0COLOR)
                                                                       (T 1COLOR))
                                                                    4)
                                                              (COND
                                                                 ([ZEROP (LOGAND SWORDCONTENTS
                                                                                (\BITMASK
                                                                                 (ADD1 SBITOFFSET]
                                                                  0COLOR)
                                                                 (T 1COLOR])
                               (PROGN [\PUTBASEBYTE DBASE 0
                                             (LOGOR (LLSH (COND
                                                             ((ZEROP (LOGAND SWORDCONTENTS
                                                                            (\BITMASK SBITOFFSET)))
                                                              0COLOR)
                                                             (T 1COLOR))
                                                          4)
                                                    (COND
                                                       ([ZEROP (LOGAND SWORDCONTENTS
                                                                      (\BITMASK (ADD1 SBITOFFSET]
                                                        0COLOR)
                                                       (T 1COLOR]
                                      (\PUTBASEBYTE
                                       DBASE 1
                                       (LOGOR (LLSH (COND
                                                       ([ZEROP (LOGAND SWORDCONTENTS
                                                                      (\BITMASK (IPLUS SBITOFFSET 2]
                                                        0COLOR)
                                                       (T 1COLOR))
                                                    4)
                                              (LOGAND (\GETBASE DBASE 0)
                                                     15]
                     (RETURN))
                    (T                                       (* move 4 bits from source to 
                                                             destination.)
                       [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET
                                                               (0 (fetch (NIBBLES N1) of SBASE))
                                                               (4 (fetch (NIBBLES N2) of SBASE))
                                                               (8 (fetch (NIBBLES N3) of SBASE))
                                                               (fetch (NIBBLES N4) of SBASE]
                       (SETQ DBASE (\ADDBASE DBASE 1))
                       (SETQ WIDTH (IDIFFERENCE WIDTH 4))
                       [COND
                          ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4))
                               16)
                           (SETQ SBITOFFSET 0)
                           (SETQ SBASE (\ADDBASE SBASE 1]
                       (GO ONEWRDLP)))
             LP  (COND
                    ((IGREATERP WIDTH (SUB1 BITSPERWORD))    (* move a source word's worth of bits.)
                     (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (NIBBLES N1) of SBASE)))
                     (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (NIBBLES N2) of SBASE)))
                     (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (NIBBLES N3) of SBASE)))
                     (\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch (NIBBLES N4) of SBASE)))
                     (SETQ DBASE (\ADDBASE DBASE 4))
                     (SETQ SBASE (\ADDBASE SBASE 1))
                     (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))
                     (GO LP))
                    (T                                       (* finish off last less than 16 bits.)
                       (GO ONEWRDLP])
        (1 
          
          (* moving bits that are aligned with 1 extra bit in the following word of the 
          source.)

           [PROG NIL
             ONEWRDLP
                                                             (* SBITOFFSET is either 0, 4, 8 or 12)
                 (COND
                    ((AND (EQ SBITOFFSET 1)
                          (IGREATERP WIDTH (SUB1 BITSPERWORD)))
                                                             (* go to center loop.)
                     (GO LP))
                    ((IGREATERP 4 WIDTH)
                     [PROG (SWORDCONTENTS)
                           (SETQ SWORDCONTENTS (\GETBASE SBASE 0))
                           (SELECTQ WIDTH
                               (0)
                               (1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
                                                                       ((ZEROP (LOGAND SWORDCONTENTS
                                                                                      (\BITMASK
                                                                                       SBITOFFSET)))
                                                                        0COLOR)
                                                                       (T 1COLOR))
                                                                    4)
                                                              (LOGAND (\GETBASEBYTE DBASE 0)
                                                                     15))))
                               (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
                                                                       ((ZEROP (LOGAND SWORDCONTENTS
                                                                                      (\BITMASK
                                                                                       SBITOFFSET)))
                                                                        0COLOR)
                                                                       (T 1COLOR))
                                                                    4)
                                                              (COND
                                                                 ([ZEROP (LOGAND SWORDCONTENTS
                                                                                (\BITMASK
                                                                                 (ADD1 SBITOFFSET]
                                                                  0COLOR)
                                                                 (T 1COLOR])
                               (PROGN [\PUTBASEBYTE DBASE 0
                                             (LOGOR (LLSH (COND
                                                             ((ZEROP (LOGAND SWORDCONTENTS
                                                                            (\BITMASK SBITOFFSET)))
                                                              0COLOR)
                                                             (T 1COLOR))
                                                          4)
                                                    (COND
                                                       ([ZEROP (LOGAND SWORDCONTENTS
                                                                      (\BITMASK (ADD1 SBITOFFSET]
                                                        0COLOR)
                                                       (T 1COLOR]
                                      (\PUTBASEBYTE
                                       DBASE 1
                                       (LOGOR (LLSH (COND
                                                       ([ZEROP (LOGAND SWORDCONTENTS
                                                                      (\BITMASK (IPLUS SBITOFFSET 2]
                                                        0COLOR)
                                                       (T 1COLOR))
                                                    4)
                                              (LOGAND (\GETBASE DBASE 0)
                                                     15]
                     (RETURN))
                    (T                                       (* move 4 bits from source to 
                                                             destination.)
                       [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET
                                                               (1 (fetch (ONEOFFSETBITACCESS BITS1TO4
                                                                                ) of SBASE))
                                                               (5 (fetch (ONEOFFSETBITACCESS BITS5TO8
                                                                                ) of SBASE))
                                                               (9 (fetch (ONEOFFSETBITACCESS 
                                                                                BITS9TO12)
                                                                     of SBASE))
                                                               (LOGOR (LLSH (fetch (
                                                                                   ONEOFFSETBITACCESS
                                                                                    BITS13TO15)
                                                                               of SBASE)
                                                                            1)
                                                                      (fetch (ODD2BITNIBBLES BIT0)
                                                                         of (SETQ SBASE
                                                                             (\ADDBASE SBASE 1]
                       (SETQ DBASE (\ADDBASE DBASE 1))
                       (SETQ WIDTH (IDIFFERENCE WIDTH 4))
                       (COND
                          ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4))
                               17)
          
          (* SBASE has already been incremented as part of fetching the last 4 bits.)

                           (SETQ SBITOFFSET 1)))
                       (GO ONEWRDLP)))
             LP  (COND
                    ((IGREATERP WIDTH (SUB1 BITSPERWORD))    (* move a source word's worth of bits.)
                     (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (ONEOFFSETBITACCESS BITS1TO4)
                                                            of SBASE)))
                     (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (ONEOFFSETBITACCESS BITS5TO8)
                                                            of SBASE)))
                     (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (ONEOFFSETBITACCESS BITS9TO12)
                                                            of SBASE)))
                     [\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch (ONEOFFSETBITACCESS
                                                                              BITS13TO15)
                                                                         of SBASE)
                                                                      1)
                                                                (fetch (ODD2BITNIBBLES BIT0)
                                                                   of (SETQ SBASE (\ADDBASE SBASE 1]
                     (SETQ DBASE (\ADDBASE DBASE 4))
                     (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))
                     (GO LP))
                    (T                                       (* finish off last less than 16 bits.)
                       (GO ONEWRDLP])
        (2 
          
          (* moving bits that are aligned with 2 extra bits in the following word of the 
          source.)

           [PROG NIL
             ONEWRDLP
                                                             (* SBITOFFSET is either 2, 6, 10 or 14)
                 (COND
                    ((AND (EQ SBITOFFSET 2)
                          (IGREATERP WIDTH (SUB1 BITSPERWORD)))
                                                             (* go to center loop.)
                     (GO LP))
                    ((IGREATERP 4 WIDTH)
                     [PROG (SWORDCONTENTS)
                           (SETQ SWORDCONTENTS (\GETBASE SBASE 0))
                           (SELECTQ WIDTH
                               (0)
                               (1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
                                                                       ((ZEROP (LOGAND SWORDCONTENTS
                                                                                      (\BITMASK
                                                                                       SBITOFFSET)))
                                                                        0COLOR)
                                                                       (T 1COLOR))
                                                                    4)
                                                              (LOGAND (\GETBASEBYTE DBASE 0)
                                                                     15))))
                               (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
                                                                       ((ZEROP (LOGAND SWORDCONTENTS
                                                                                      (\BITMASK
                                                                                       SBITOFFSET)))
                                                                        0COLOR)
                                                                       (T 1COLOR))
                                                                    4)
                                                              (COND
                                                                 ([ZEROP (LOGAND SWORDCONTENTS
                                                                                (\BITMASK
                                                                                 (ADD1 SBITOFFSET]
                                                                  0COLOR)
                                                                 (T 1COLOR])
                               (PROGN                        (* first two bits are always in this 
                                                             word.)
                                [\PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
                                                                      ((ZEROP (LOGAND SWORDCONTENTS
                                                                                     (\BITMASK 
                                                                                           SBITOFFSET
                                                                                            )))
                                                                       0COLOR)
                                                                      (T 1COLOR))
                                                                   4)
                                                             (COND
                                                                ([ZEROP (LOGAND SWORDCONTENTS
                                                                               (\BITMASK (ADD1 
                                                                                           SBITOFFSET
                                                                                               ]
                                                                 0COLOR)
                                                                (T 1COLOR]
                                (\PUTBASEBYTE
                                 DBASE 1
                                 (LOGOR (LLSH (COND
                                                 ([ZEROP (COND
                                                            ((EQ SBITOFFSET 14)
          
          (* the next one is in the next word if the offset is 14)

                                                             (fetch (TWOOFFSETBITACCESS 
                                                                           BIT0OFNEXTWORD)
                                                                of SBASE))
                                                            (T (LOGAND SWORDCONTENTS
                                                                      (\BITMASK (IPLUS SBITOFFSET 2]
                                                  0COLOR)
                                                 (T 1COLOR))
                                              4)
                                        (LOGAND (\GETBASE DBASE 0)
                                               15]
                     (RETURN))
                    (T                                       (* move 4 bits from source to 
                                                             destination.)
                       [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET
                                                               (2 (fetch (TWOOFFSETBITACCESS BITS2TO5
                                                                                ) of SBASE))
                                                               (6 (fetch (TWOOFFSETBITACCESS BITS6TO9
                                                                                ) of SBASE))
                                                               (10 (fetch (TWOOFFSETBITACCESS 
                                                                                 BITS10TO13)
                                                                      of SBASE))
                                                               (LOGOR (LLSH (fetch (
                                                                                   TWOOFFSETBITACCESS
                                                                                    BITS14TO15)
                                                                               of SBASE)
                                                                            2)
                                                                      (fetch (TWOOFFSETBITACCESS
                                                                              BITS0TO1)
                                                                         of (SETQ SBASE
                                                                             (\ADDBASE SBASE 1]
                       (SETQ DBASE (\ADDBASE DBASE 1))
                       (SETQ WIDTH (IDIFFERENCE WIDTH 4))
                       (COND
                          ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4))
                               18)
          
          (* SBASE has already been incremented as part of fetching the last 4 bits.)

                           (SETQ SBITOFFSET 2)))
                       (GO ONEWRDLP)))
             LP  (COND
                    ((IGREATERP WIDTH (SUB1 BITSPERWORD))    (* move a source word's worth of bits.)
                     (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS2TO5)
                                                            of SBASE)))
                     (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS6TO9)
                                                            of SBASE)))
                     (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS10TO13)
                                                            of SBASE)))
                     [\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch (TWOOFFSETBITACCESS
                                                                              BITS14TO15)
                                                                         of SBASE)
                                                                      2)
                                                                (fetch (TWOOFFSETBITACCESS BITS0TO1)
                                                                   of (SETQ SBASE (\ADDBASE SBASE 1]
                     (SETQ DBASE (\ADDBASE DBASE 4))
                     (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))
                     (GO LP))
                    (T                                       (* finish off last less than 16 bits.)
                       (GO ONEWRDLP])
        (PROG NIL
          
          (* moving bits that are aligned with 3 extra bits in the following word of the 
          source.)

          ONEWRDLP
                                                             (* SBITOFFSET is either 3, 7, 11 or 15)
              (COND
                 ((AND (EQ SBITOFFSET 3)
                       (IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.)
                  (GO LP))
                 ((IGREATERP 4 WIDTH)
                  [PROG (SWORDCONTENTS)
                        (SETQ SWORDCONTENTS (\GETBASE SBASE 0))
                        (SELECTQ WIDTH
                            (0)
                            (1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND
                                                                    ((ZEROP (LOGAND SWORDCONTENTS
                                                                                   (\BITMASK 
                                                                                          SBITOFFSET)
                                                                                   ))
                                                                     0COLOR)
                                                                    (T 1COLOR))
                                                                 4)
                                                           (LOGAND (\GETBASEBYTE DBASE 0)
                                                                  15))))
                            (2 [PUTBASEBYTE DBASE 0
                                      (LOGOR (LLSH (COND
                                                      ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK 
                                                                                           SBITOFFSET
                                                                                           )))
                                                       0COLOR)
                                                      (T 1COLOR))
                                                   4)
                                             (COND
                                                ([ZEROP (COND
                                                           ((EQ SBITOFFSET 15)
          
          (* the next bit is in the next word if the offset is 15)

                                                            (fetch (TWOOFFSETBITACCESS BIT0OFNEXTWORD
                                                                          ) of SBASE))
                                                           (T (LOGAND SWORDCONTENTS
                                                                     (\BITMASK (IPLUS SBITOFFSET 2]
                                                 0COLOR)
                                                (T 1COLOR])
                            (PROGN                           (* first two bits are always in this 
                                                             word.)
                             [\PUTBASEBYTE DBASE 0
                                    (LOGOR (LLSH (COND
                                                    ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK 
                                                                                         SBITOFFSET))
                                                            )
                                                     0COLOR)
                                                    (T 1COLOR))
                                                 4)
                                           (COND
                                              ([ZEROP (COND
                                                         ((EQ SBITOFFSET 15)
          
          (* the next bit is in the next word if the offset is 15)

                                                          (fetch (TWOOFFSETBITACCESS BIT0OFNEXTWORD)
                                                             of SBASE))
                                                         (T (LOGAND SWORDCONTENTS
                                                                   (\BITMASK (IPLUS SBITOFFSET 2]
                                               0COLOR)
                                              (T 1COLOR]
                             (\PUTBASEBYTE
                              DBASE 1
                              (LOGOR (LLSH (COND
                                              ([ZEROP (COND
                                                         ((EQ SBITOFFSET 15)
          
          (* the next one is in the next word if the offset is 15)

                                                          (fetch (TWOOFFSETBITACCESS BIT1OFNEXTWORD)
                                                             of SBASE))
                                                         (T (LOGAND SWORDCONTENTS
                                                                   (\BITMASK (IPLUS SBITOFFSET 2]
                                               0COLOR)
                                              (T 1COLOR))
                                           4)
                                     (LOGAND (\GETBASE DBASE 0)
                                            15]
                  (RETURN))
                 (T                                          (* move 4 bits from source to 
                                                             destination.)
                    [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET
                                                            (3 (fetch (THREEOFFSETBTACCESS BITS3TO6)
                                                                  of SBASE))
                                                            (7 (fetch (THREEOFFSETBTACCESS BITS7TO10)
                                                                  of SBASE))
                                                            (11 (fetch (THREEOFFSETBTACCESS 
                                                                              BITS11TO14)
                                                                   of SBASE))
                                                            (LOGOR (LLSH (fetch (ODD2BITNIBBLES
                                                                                 BIT15) of SBASE)
                                                                         3)
                                                                   (fetch (THREEOFFSETBTACCESS 
                                                                                 BITS0TO2)
                                                                      of (SETQ SBASE (\ADDBASE SBASE 
                                                                                            1]
                    (SETQ DBASE (\ADDBASE DBASE 1))
                    (SETQ WIDTH (IDIFFERENCE WIDTH 4))
                    (COND
                       ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4))
                            19)
          
          (* SBASE has already been incremented as part of fetching the last 4 bits.)

                        (SETQ SBITOFFSET 3)))
                    (GO ONEWRDLP)))
          LP  (COND
                 ((IGREATERP WIDTH (SUB1 BITSPERWORD))       (* move a source word's worth of bits.)
                  (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (THREEOFFSETBTACCESS BITS3TO6)
                                                         of SBASE)))
                  (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (THREEOFFSETBTACCESS BITS7TO10)
                                                         of SBASE)))
                  (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (THREEOFFSETBTACCESS BITS11TO14)
                                                         of SBASE)))
                  [\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch (ODD2BITNIBBLES BIT15)
                                                                      of SBASE)
                                                                   3)
                                                             (fetch (THREEOFFSETBTACCESS BITS0TO2)
                                                                of (SETQ SBASE (\ADDBASE SBASE 1]
                  (SETQ DBASE (\ADDBASE DBASE 4))
                  (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))
                  (GO LP))
                 (T                                          (* finish off last less than 16 bits.)
                    (GO ONEWRDLP])

(\8BITLINEBLT
  [LAMBDA (SBASE SBITOFFSET DBASE DBITOFFSET WIDTH MAPBASE 0COLOR 1COLOR)
                                                             (* edited%: "16-SEP-82 19:36")
          
          (* moves one line of a black and white bitmap into a color bitmap using a 
          mapping table.)

    [COND
       ((EQ 1 DBITOFFSET)
          
          (* move the first bit specially to get to word boundary in destination.)

        (\PUTBASEBYTE DBASE 1 (COND
                                 ((ZEROP (LOGAND (\GETBASE SBASE 0)
                                                (\BITMASK SBITOFFSET)))
                                  0COLOR)
                                 (T 1COLOR)))
        [COND
           ((EQ (SETQ SBITOFFSET (ADD1 SBITOFFSET))
                BITSPERWORD)                                 (* SBITOFFSET flowed onto next word.)
            (SETQ SBITOFFSET 0)
            (SETQ SBASE (\ADDBASE SBASE 1]
        (SETQ DBITOFFSET 0)
        (SETQ DBASE (\ADDBASE DBASE 1))
        (SETQ WIDTH (SUB1 WIDTH]
    (COND
       ((ZEROP (MOD SBITOFFSET 2))                           (* case of moving even aligned bits.)
        (PROG NIL
          LP  [COND
                 ((AND (IGREATERP WIDTH (SUB1 BITSPERWORD))
                       (EQ SBITOFFSET 0))                    (* move a source word's worth of bits.)
                  (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN1) of SBASE)))
                  (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN2) of SBASE)))
                  (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN3) of SBASE)))
                  (\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN4) of SBASE)))
                  (\PUTBASE DBASE 4 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN5) of SBASE)))
                  (\PUTBASE DBASE 5 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN6) of SBASE)))
                  (\PUTBASE DBASE 6 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN7) of SBASE)))
                  (\PUTBASE DBASE 7 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN8) of SBASE)))
                  (SETQ DBASE (\ADDBASE DBASE 8))
                  (SETQ SBASE (\ADDBASE SBASE 1))
                  (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)))
                 ((EQ WIDTH 0)
                  (RETURN))
                 ((EQ WIDTH 1)                               (* move last bit specially)
                  (\PUTBASEBYTE DBASE 0 (COND
                                           ((ZEROP (LOGAND (\GETBASE SBASE 0)
                                                          (\BITMASK SBITOFFSET)))
                                            0COLOR)
                                           (T 1COLOR)))
                  (RETURN))
                 (T 
          
          (* move the rest of the first word or last word two at a time.)

                    (\PUTBASEBYTE DBASE 0 (COND
                                             ((ZEROP (LOGAND (\GETBASE SBASE 0)
                                                            (\BITMASK SBITOFFSET)))
                                              0COLOR)
                                             (T 1COLOR)))
                    (\PUTBASEBYTE DBASE 1 (COND
                                             ([ZEROP (LOGAND (\GETBASE SBASE 0)
                                                            (\BITMASK (ADD1 SBITOFFSET]
                                              0COLOR)
                                             (T 1COLOR)))
                    (SETQ DBASE (\ADDBASE DBASE 1))
                    (SETQ WIDTH (IDIFFERENCE WIDTH 2))
                    (COND
                       ((EQ SBITOFFSET 14)
                        (SETQ SBASE (\ADDBASE SBASE 1))
                        (SETQ SBITOFFSET 0))
                       (T (SETQ SBITOFFSET (IPLUS SBITOFFSET 2]
              (GO LP)))
       (T                                                    (* moving odd aligned bits.)
          (PROG NIL
            LP  [COND
                   ((AND (IGREATERP WIDTH (SUB1 BITSPERWORD))
                         (EQ SBITOFFSET 1))
          
          (* move a source word's worth of bits. move the 1th thru 15th bits in the first 
          word plus the 0th bit in the next word.)

                    (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT1) of SBASE)))
                    (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT2) of SBASE)))
                    (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT3) of SBASE)))
                    (\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT4) of SBASE)))
                    (\PUTBASE DBASE 4 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT5) of SBASE)))
                    (\PUTBASE DBASE 5 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT6) of SBASE)))
                    (\PUTBASE DBASE 6 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT7) of SBASE)))
                    (\PUTBASEBYTE DBASE 14 (COND
                                              ((ZEROP (fetch (ODD2BITNIBBLES BIT15) of SBASE))
                                               0COLOR)
                                              (T 1COLOR)))
                    (\PUTBASEBYTE DBASE 15 (COND
                                              ([ZEROP (fetch (ODD2BITNIBBLES BIT0)
                                                         of (SETQ SBASE (\ADDBASE SBASE 1]
                                               0COLOR)
                                              (T 1COLOR)))
                    (SETQ DBASE (\ADDBASE DBASE 8))
                    (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)))
                   ((EQ WIDTH 0)
                    (RETURN))
                   ((EQ WIDTH 1)                             (* move last bit specially)
                    (\PUTBASEBYTE DBASE 0 (COND
                                             ((ZEROP (LOGAND (\GETBASE SBASE 0)
                                                            (\BITMASK SBITOFFSET)))
                                              0COLOR)
                                             (T 1COLOR)))
                    (RETURN))
                   ((EQ SBITOFFSET 15)
          
          (* case of moving one bit from each of two words in the slow case.)

                    (\PUTBASEBYTE DBASE 0 (COND
                                             ((ZEROP (fetch (ODD2BITNIBBLES BIT15) of SBASE))
                                              0COLOR)
                                             (T 1COLOR)))
                    (\PUTBASEBYTE DBASE (SETQ SBITOFFSET 1)
                           (COND
                              ([ZEROP (fetch (ODD2BITNIBBLES BIT0) of (SETQ SBASE (\ADDBASE SBASE 1]
                               0COLOR)
                              (T 1COLOR)))
                    (SETQ WIDTH (IDIFFERENCE WIDTH 2))
                    (SETQ DBASE (\ADDBASE DBASE 1)))
                   (T 
          
          (* move the rest of the first word or the rest of last word two at a time.)

                      (\PUTBASEBYTE DBASE 0 (COND
                                               ((ZEROP (LOGAND (\GETBASE SBASE 0)
                                                              (\BITMASK SBITOFFSET)))
                                                0COLOR)
                                               (T 1COLOR)))
                      (\PUTBASEBYTE DBASE 1 (COND
                                               ([ZEROP (LOGAND (\GETBASE SBASE 0)
                                                              (\BITMASK (ADD1 SBITOFFSET]
                                                0COLOR)
                                               (T 1COLOR)))
                      (SETQ SBITOFFSET (IPLUS SBITOFFSET 2))
                      (SETQ WIDTH (IDIFFERENCE WIDTH 2))
                      (SETQ DBASE (\ADDBASE DBASE 1]
                (GO LP])

(\24BITLINEBLT
  [LAMBDA (SBASE SLEFT DBASE DLEFT WIDTH 0COLOR 1COLOR)      (* kbr%: "15-Feb-86 10:56")
          
          (* moves one line of a black and white bitmap into a color bitmap using a 
          mapping table.)

    (PROG NIL
          (for SX from SLEFT to (IPLUS SLEFT WIDTH -1) as DX from DLEFT
             do (\PUTBASE24 DBASE DX (COND
                                        ([ZEROP (LOGAND (\GETBASE SBASE (FOLDLO SX BITSPERWORD))
                                                       (\BITMASK (LOGAND SX 15]
                                         0COLOR)
                                        (T 1COLOR])

(\GETBASE24
  [LAMBDA (X D)                                              (* kbr%: "13-Feb-86 21:07")
                                                             (* Get Dth 24bit pixel from packed X.
                                                             *)
    (PROG (DWORD ANSWER)
          (SETQ DWORD (FOLDLO (ITIMES 24 D)
                             BITSPERWORD))
          [SETQ ANSWER (SELECTQ (LOGAND D 1)
                           (0 
          
          (* Get nibbles 1 0 of DWORD and nibble 1 of following word.
          *)

                              (LOGOR (LLSH (\GETBASE X DWORD)
                                           8)
                                     (LRSH (\GETBASE X (ADD1 DWORD))
                                           8)))
                           (PROGN 
          
          (* Get nibble 0 of DWORD and nibbles 1 0 of following word.
          *)

                                  (LOGOR (LLSH (LOGAND (\GETBASE X DWORD)
                                                      (MASK.1'S 0 8))
                                               16)
                                         (\GETBASE X (ADD1 DWORD]
          (RETURN ANSWER])

(\PUTBASE24
  [LAMBDA (X D V)                                            (* kbr%: "13-Feb-86 21:19")
                                                             (* Set Dth 24bit pixel from packed X.
                                                             *)
    (PROG (DWORD)
          (SETQ DWORD (FOLDLO (ITIMES 24 D)
                             BITSPERWORD))
          (SELECTQ (LOGAND D 1)
              (0 
          
          (* Replace nibbles 1 0 of DWORD and nibble 1 of following word.
          *)

                 (\PUTBASE X DWORD (LRSH V 8))
                 [\PUTBASE X (ADD1 DWORD)
                        (LOGOR (LLSH (LOGAND V (MASK.1'S 0 8))
                                     8)
                               (LOGAND (\GETBASE X DWORD)
                                      (MASK.1'S 0 8])
              (PROGN 
          
          (* Replace nibble 0 of DWORD and nibbles 1 0 of following word.
          *)

                     (\PUTBASE X DWORD (LOGOR (LOGAND (\GETBASE X DWORD)
                                                     (LLSH (MASK.1'S 0 8)
                                                           8))
                                              (LRSH V 16)))
                     (\PUTBASE X (ADD1 DWORD)
                            (LOGAND V (MASK.1'S 0 16])

(COLORTEXTUREFROMCOLOR#
  [LAMBDA (COLOR# BITSPERPIXEL)                              (* kbr%: "27-Feb-86 16:48")
          
          (* returns a TEXTURE that is COLOR# tessellated in a pattern to put down 
          BITSPERPIXEL per pixel color)

    (PROG (TEXTURE)
          (COND
             ((type? BITMAP COLOR#)                          (* already is a texture.)
              (RETURN COLOR#)))
          (SETQ COLOR# (COLORNUMBERP COLOR# BITSPERPIXEL))
          (SETQ TEXTURE (SELECTQ BITSPERPIXEL
                            (4 (PROG (TEXTUREBITMAP BITPATTERN)
                                     (SETQ TEXTUREBITMAP (BITMAPCREATE 4 4 4))
                                     (SETQ BITPATTERN (LOGOR (LLSH COLOR# 12)
                                                             (LLSH COLOR# 8)
                                                             (LLSH COLOR# 4)
                                                             COLOR#))
                                     (for I from 0 to 3 do (\BITMAPWORD TEXTUREBITMAP I BITPATTERN))
                                     (RETURN TEXTUREBITMAP)))
                            (8 (PROG (TEXTUREBITMAP BITPATTERN)
                                     (SETQ TEXTUREBITMAP (BITMAPCREATE 2 4 8))
                                     (SETQ BITPATTERN (LOGOR (LLSH COLOR# 8)
                                                             COLOR#))
                                     (for I from 0 to 3 do (\BITMAPWORD TEXTUREBITMAP I BITPATTERN))
                                     (RETURN TEXTUREBITMAP)))
                            (24 
          
          (* This isn't right, but at least it won't break you.
          *)

                                (PROG (TEXTUREBITMAP BITMAPBASE)
                                      (SETQ TEXTUREBITMAP (BITMAPCREATE 2 4 24))
                                      (SETQ BITMAPBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBITMAP))
                                      (for I from 0 to 7 do (\PUTBASE24 BITMAPBASE I COLOR#))
                                      (RETURN TEXTUREBITMAP)))
                            (ERROR "Only 4, 8 and 24 bits per pixel implemented.")))
          (RETURN TEXTURE])

(\BITMAPWORD
  [LAMBDA (BM WORDN NEWBITS)                                 (* edited%: " 8-SEP-82 10:54")
          
          (* puts a words worth of bits into the WORDNth word of a bitmap.)

    (\PUTBASE (\ADDBASE (fetch (BITMAP BITMAPBASE) of BM)
                     WORDN)
           0
           (LOGAND NEWBITS WORDMASK])
)
(DEFINEQ

(COLORIZEBITMAP
  [LAMBDA (BITMAP 0COLOR 1COLOR BITSPERPIXEL)                (* kbr%: "15-Feb-86 10:13")
          
          (* creates a copy of BITMAP that is in color form allowing BITSPERPIXEL per 
          pixel. 0COLOR and 1COLOR are the color numbers that get translated from 0 and 1 
          respectively.)

    (PROG (COLORBITMAP)
          (SETQ COLORBITMAP (BITMAPCREATE (fetch (BITMAP BITMAPWIDTH) of BITMAP)
                                   (fetch (BITMAP BITMAPHEIGHT) of BITMAP)
                                   BITSPERPIXEL))
          (\BWTOCOLORBLT BITMAP 0 0 COLORBITMAP 0 0 (fetch (BITMAP BITMAPWIDTH) of BITMAP)
                 (fetch (BITMAP BITMAPHEIGHT) of BITMAP)
                 (COLORNUMBERP 0COLOR BITSPERPIXEL)
                 (COLORNUMBERP 1COLOR BITSPERPIXEL)
                 BITSPERPIXEL)
          (RETURN COLORBITMAP])

(UNCOLORIZEBITMAP
  [LAMBDA (BITMAP COLORMAP)                                  (* kbr%: " 2-Sep-85 19:21")
    (PROG (BITSPERPIXEL MAXCOLOR MAXX MAXY BWBITMAP TABLE RGB R G B BIT BASE BWBASE RASTERWIDTH 
                 BWRASTERWIDTH WORD)
          (SETQ MAXX (SUB1 (fetch (BITMAP BITMAPWIDTH) of BITMAP)))
          (SETQ MAXY (SUB1 (fetch (BITMAP BITMAPHEIGHT) of BITMAP)))
          (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP))
          (SETQ COLORMAP (OR COLORMAP (COLORMAP BITSPERPIXEL)))
          (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL))
          (SETQ BWBITMAP (BITMAPCREATE (ADD1 MAXX)
                                (ADD1 MAXY)
                                1))
          (SETQ TABLE (\ALLOCBLOCK (FOLDHI (ADD1 MAXCOLOR)
                                          2)))
          (for I from 0 to MAXCOLOR do (SETQ RGB (ELT COLORMAP I))
                                       (SETQ R (fetch (RGB RED) of RGB))
                                       (SETQ G (fetch (RGB GREEN) of RGB))
                                       (SETQ B (fetch (RGB BLUE) of RGB))
                                       (SETQ BIT (IDIFFERENCE 1 (IQUOTIENT (IPLUS R G B)
                                                                       384)))
                                       (\PUTBASE TABLE I BIT))
          (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP))
          (SETQ BWBASE (fetch (BITMAP BITMAPBASE) of BWBITMAP))
          (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP))
          (SETQ BWRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BWBITMAP))
          (SELECTQ BITSPERPIXEL
              (4 [for Y from 0 to MAXY do (SETQ WORD 0)
                                          [for X from 0 to MAXX
                                             do [SETQ WORD (LOGOR (LLSH WORD 1)
                                                                  (\GETBASE TABLE (\GETBASENYBBLE
                                                                                   BASE X]
                                                (COND
                                                   ((EQ (LOGAND X 15)
                                                        15)
                                                    (\PUTBASE BWBASE (FOLDLO X 16)
                                                           WORD)
                                                    (SETQ WORD 0]
                                          (COND
                                             ((NOT (EQ (LOGAND MAXX 15)
                                                       15))
                                              [SETQ WORD (LLSH WORD (IDIFFERENCE 15 (LOGAND MAXX 15]
                                              (\PUTBASE BWBASE (FOLDLO MAXX 16)
                                                     WORD)))
                                          (COND
                                             ((NOT (EQ Y MAXY))
                                              (SETQ BASE (\ADDBASE BASE RASTERWIDTH))
                                              (SETQ BWBASE (\ADDBASE BWBASE BWRASTERWIDTH])
              (8 [for Y from 0 to MAXY do (SETQ WORD 0)
                                          [for X from 0 to MAXX
                                             do [SETQ WORD (LOGOR (LLSH WORD 1)
                                                                  (\GETBASE TABLE (\GETBASEBYTE
                                                                                   BASE X]
                                                (COND
                                                   ((EQ (LOGAND X 15)
                                                        15)
                                                    (\PUTBASE BWBASE (FOLDLO X 16)
                                                           WORD)
                                                    (SETQ WORD 0]
                                          (COND
                                             ((NOT (EQ (LOGAND MAXX 15)
                                                       15))
                                              [SETQ WORD (LLSH WORD (IDIFFERENCE 15 (LOGAND MAXX 15]
                                              (\PUTBASE BWBASE (FOLDLO MAXX 16)
                                                     WORD)))
                                          (COND
                                             ((NOT (EQ Y MAXY))
                                              (SETQ BASE (\ADDBASE BASE RASTERWIDTH))
                                              (SETQ BWBASE (\ADDBASE BWBASE BWRASTERWIDTH])
              NIL)
          (RETURN BWBITMAP])
)

(RPAQ? \1COLORMENU NIL)

(RPAQ? \4COLORMENU NIL)

(RPAQ? \8COLORMENU NIL)
(DEFINEQ

(COLORMENU
  [LAMBDA (BITSPERPIXEL)                                     (* kbr%: " 5-Jun-85 18:24")
                                                             (* Make a BITSPERPIXEL color menu.
                                                             *)
    (PROG (MENU ITEMS MENUCOLUMNS MENUROWS BITMAP)           (* Try to find old menu.
                                                             *)
          (SETQ MENU (SELECTQ BITSPERPIXEL
                         (1 \1COLORMENU)
                         (4 \4COLORMENU)
                         (8 \8COLORMENU)
                         (\ILLEGAL.ARG BITSPERPIXEL)))
          (COND
             (MENU (RETURN MENU)))                           (* Calculate menu items.
                                                             *)
          (SETQ ITEMS (SELECTQ BITSPERPIXEL
                          (1 (for COLOR from 0 to 1 as SHADE in (LIST WHITESHADE BLACKSHADE)
                                collect (LIST (PROGN (SETQ BITMAP (BITMAPCREATE 32 32))
                                                     (BLTSHADE SHADE BITMAP)
                                                     BITMAP)
                                              COLOR)))
                          (4 (for COLOR from 0 to 15
                                collect (LIST (PROGN (SETQ BITMAP (BITMAPCREATE 16 16 4))
                                                     (BLTSHADE COLOR BITMAP)
                                                     BITMAP)
                                              COLOR)))
                          (8 (for COLOR from 0 to 255
                                collect (LIST (PROGN (SETQ BITMAP (BITMAPCREATE 8 8 8))
                                                     (BLTSHADE COLOR BITMAP)
                                                     BITMAP)
                                              COLOR)))
                          (SHOULDNT)))
          (SETQ MENUROWS (SELECTQ BITSPERPIXEL
                             (1 1)
                             (4 4)
                             (8 16)
                             (SHOULDNT)))
          (SETQ MENUCOLUMNS (SELECTQ BITSPERPIXEL
                                (1 2)
                                (4 4)
                                (8 16)
                                (SHOULDNT)))
          (SETQ MENU (create MENU
                            ITEMS _ ITEMS
                            MENUROWS _ MENUROWS
                            MENUCOLUMNS _ MENUCOLUMNS
                            MENUBORDERSIZE _ 1))
          (SELECTQ BITSPERPIXEL
              (1 (SETQ \1COLORMENU MENU))
              (4 (SETQ \4COLORMENU MENU))
              (8 (SETQ \8COLORMENU MENU))
              (SHOULDNT))
          (RETURN MENU])

(CURSORCOLOR
  [LAMBDA (COLOR)                                            (* edited%: " 4-Jun-85 15:56")
    (PROG (IMAGE MASK)
          (SETQ IMAGE (fetch (CURSOR CUIMAGE) of \CURRENTCURSOR))
          (SETQ MASK (fetch (CURSOR CUMASK) of \CURRENTCURSOR))
          (BLTSHADE COLOR IMAGE)
          (BITBLT MASK NIL NIL IMAGE NIL NIL NIL NIL 'INVERT 'ERASE])
)
(DECLARE%: EVAL@COMPILE

(RECORD RGB (RED GREEN BLUE))

(RECORD HLS (HUE LIGHTNESS SATURATION))
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE

(BLOCKRECORD NIBBLES ((N1 BITS 4)
                          (N2 BITS 4)
                          (N3 BITS 4)
                          (N4 BITS 4)))

(BLOCKRECORD ONEOFFSETBITACCESS ((BIT0 BITS 1)
                                     (BITS1TO4 BITS 4)
                                     (BITS5TO8 BITS 4)
                                     (BITS9TO12 BITS 4)
                                     (BITS13TO15 BITS 3)))

(BLOCKRECORD TWOOFFSETBITACCESS ((BITS0TO1 BITS 2)
                                     (BITS2TO5 BITS 4)
                                     (BITS6TO9 BITS 4)
                                     (BITS10TO13 BITS 4)
                                     (BITS14TO15 BITS 2)
                                     (BIT0OFNEXTWORD BITS 1)
                                     (BIT1OFNEXTWORD BITS 1)
                                     (BITS2TO15OFNEXTWORD BITS 14)))

(BLOCKRECORD THREEOFFSETBTACCESS ((BITS0TO2 BITS 3)
                                      (BITS3TO6 BITS 4)
                                      (BITS7TO10 BITS 4)
                                      (BITS11TO14 BITS 4)
                                      (BIT15 BITS 1)))

(BLOCKRECORD 2BITNIBBLES ((EN1 BITS 2)
                              (EN2 BITS 2)
                              (EN3 BITS 2)
                              (EN4 BITS 2)
                              (EN5 BITS 2)
                              (EN6 BITS 2)
                              (EN7 BITS 2)
                              (EN8 BITS 2)))

(BLOCKRECORD ODD2BITNIBBLES ((BIT0 BITS 1)
                                 (ODD2BIT1 BITS 2)
                                 (ODD2BIT2 BITS 2)
                                 (ODD2BIT3 BITS 2)
                                 (ODD2BIT4 BITS 2)
                                 (ODD2BIT5 BITS 2)
                                 (ODD2BIT6 BITS 2)
                                 (ODD2BIT7 BITS 2)
                                 (BIT15 BITS 1)))
)
)
(DECLARE%: EVAL@COMPILE 

(RPAQQ BITSPERWORD 16)


(CONSTANTS (BITSPERWORD 16))
)

(RPAQ? \COLORDISPLAYFDEV )

(RPAQ? \4COLORMAP (CMYCOLORMAP 2 1 1 4))

(RPAQ? \8COLORMAP (CMYCOLORMAP 3 3 2 8))

(RPAQ? \COLORDISPLAYBITS )

(RPAQ? ColorScreenBitMap )

(RPAQ? \COLORSCREEN )
(DEFINEQ

(PSEUDOCOLOR
  [LAMBDA (TABLE DESTINATION LEFT BOTTOM WIDTH HEIGHT)       (* kbr%: " 2-Sep-85 19:08")
    (DECLARE (LOCALVARS . T))
    (PROG (left top bottom right width height DESTDD DESTSTRM)
          (COND
             ((NULL LEFT)
              (SETQ LEFT 0)))
          (COND
             ((NULL BOTTOM)
              (SETQ BOTTOM 0)))
          
          (* left, right top and bottom are the limits in destination taking into account 
          Clipping Regions. Clip to region in the arguments of this call.)

          [COND
             [(type? BITMAP DESTINATION)
              (SETQ left 0)
              (SETQ bottom 0)
              (SETQ right (SUB1 (fetch (BITMAP BITMAPWIDTH) of DESTINATION)))
              (SETQ top (SUB1 (fetch (BITMAP BITMAPHEIGHT) of DESTINATION]
             ((SETQ DESTDD (\GETDISPLAYDATA DESTINATION))
              (SETQ DESTSTRM DESTINATION)
              (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DESTDD))
              (SETQ LEFT (\DSPTRANSFORMX LEFT DESTDD))
              (SETQ BOTTOM (\DSPTRANSFORMY BOTTOM DESTDD))
              (PROGN                                         (* compute limits based on clipping 
                                                             regions.)
                     (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD))
                     (SETQ bottom (fetch (\DISPLAYDATA DDClippingBottom) of DESTDD))
                     (SETQ right (fetch (\DISPLAYDATA DDClippingRight) of DESTDD))
                     (SETQ top (fetch (\DISPLAYDATA DDClippingTop) of DESTDD]
          (COND
             ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATION)
                       8))
              (ERROR "Pseudocolor only implemented for 8 bitsperpixel bitmaps" DESTINATION)))
          [PROGN (SETQ left (IMAX LEFT left))
                 (SETQ bottom (IMAX BOTTOM bottom))
                 [COND
                    (WIDTH                                   (* WIDTH is optional)
                           (SETQ right (IMIN (IPLUS LEFT WIDTH)
                                             right]
                 (COND
                    (HEIGHT                                  (* HEIGHT is optional)
                           (SETQ top (IMIN (IPLUS BOTTOM HEIGHT)
                                           top]              (* Clip and translate coordinates.)
          (SETQ width (IPLUS right (IMINUS left)
                             1))
          (SETQ height (IPLUS top (IMINUS bottom)
                              1))
          (COND
             (DESTSTRM (.WHILE.TOP.DS. DESTSTRM (\PSEUDOCOLOR.BITMAP TABLE DESTINATION left bottom 
                                                       width height)))
             (T (\PSEUDOCOLOR.BITMAP TABLE DESTINATION left bottom width height])

(\PSEUDOCOLOR.BITMAP
  [LAMBDA (TABLE BITMAP LEFT BOTTOM WIDTH HEIGHT)            (* kbr%: "10-Jul-85 22:33")
    (\PSEUDOCOLOR.UFN (fetch (ARRAYP BASE) of TABLE)
           BITMAP LEFT BOTTOM WIDTH 0 HEIGHT])

(\PSEUDOCOLOR.UFN
  [LAMBDA (TABLEBASE BITMAP LEFT BOTTOM WIDTH ZERO HEIGHT)   (* kbr%: "10-Jul-85 22:37")
          
          (* * Substitutes colors according to TABLEBASE within region of 8 bitsperpixel 
          BITMAP. *)

    (PROG (BASE RASTERWIDTH BMHEIGHT TOP RIGHT ROWBASE)
          (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP))
          (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP))
          (SETQ BMHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP))
          (SETQ RIGHT (IPLUS LEFT WIDTH -1))
          (SETQ BOTTOM (ITIMES RASTERWIDTH (IDIFFERENCE (SUB1 BMHEIGHT)
                                                  BOTTOM)))
          [SETQ TOP (IDIFFERENCE BOTTOM (ITIMES RASTERWIDTH (SUB1 HEIGHT]
          (for Y from TOP to BOTTOM by RASTERWIDTH
             do (SETQ ROWBASE (\ADDBASE BASE Y))
                (for X from LEFT to RIGHT do (\PUTBASEBYTE ROWBASE X (\GETBASE TABLEBASE
                                                                            (\GETBASEBYTE ROWBASE X])
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \COLORDISPLAYFDEV \COLORDISPLAYBITS ColorScreenBitMap \4COLORMAP \8COLORMAP)
)


         (* NOTE%: This is very bad. I shouldn't have to and don't really want to do the 
       following, but since about March 86, someone did something really nonstandard 
       wrt Helvetica fonts so that the in core versions are not equal to what is 
       stored on file. The SETFONTDESCRIPTOR and friends undoes this kludge which has 
       never been explained to LISPCORE^ by the person who brain damaged Helvetica 
       this way. If I don't undo this kludge by someone else, then color menus come 
       out wrong. *)


(SETFONTDESCRIPTOR 'HELVETICA 10 'MRR 0 'DISPLAY NIL)

(SETQ MENUFONT (FONTCREATE 'HELVETICA 10))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(PUTPROPS LLCOLOR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3234 18413 (COLORDISPLAY 3244 . 6216) (COLORMAPBITS 6218 . 6383) (
\CreateColorScreenBitMap 6385 . 7700) (\CREATECOLORDISPLAYFDEV 7702 . 8589) (COLORMAP 8591 . 10097) (
SCREENCOLORMAP 10099 . 10297) (SCREENCOLORMAPENTRY 10299 . 10530) (ROTATECOLORMAP 10532 . 11246) (
RGBCOLORMAP 11248 . 13187) (CMYCOLORMAP 13189 . 13702) (GRAYCOLORMAP 13704 . 14638) (COLORSCREENBITMAP
 14640 . 14882) (\COLORDISPLAYBITS 14884 . 16558) (COLORSCREEN 16560 . 16692) (SHOWCOLORTESTPATTERN 
16694 . 18411)) (18452 19097 (\STARTCOLOR 18462 . 18604) (\STOPCOLOR 18606 . 18746) (
\SENDCOLORMAPENTRY 18748 . 19095)) (19098 25014 (COLORMAPCREATE 19108 . 20098) (COLORLEVEL 20100 . 
21085) (COLORNUMBERP 21087 . 22677) (COLORFROMRGB 22679 . 23760) (INTENSITIESFROMCOLORMAP 23762 . 
24169) (SETCOLORINTENSITY 24171 . 25012)) (25015 29199 (\FAST8BIT 25025 . 27033) (\MAP4 27035 . 27915)
 (\MAP8 27917 . 29197)) (29200 29928 (\GETCOLORBRUSH 29210 . 29926)) (29929 35296 (\DRAWCOLORLINE1 
29939 . 30414) (\DRAW4BPPCOLORLINE 30416 . 32163) (\DRAW8BPPCOLORLINE 32165 . 33727) (
\DRAW24BPPCOLORLINE 33729 . 35294)) (58750 112454 (\BWTOCOLORBLT 58760 . 66317) (\4BITLINEBLT 66319 . 
98370) (\8BITLINEBLT 98372 . 106518) (\24BITLINEBLT 106520 . 107201) (\GETBASE24 107203 . 108428) (
\PUTBASE24 108430 . 109779) (COLORTEXTUREFROMCOLOR# 109781 . 112097) (\BITMAPWORD 112099 . 112452)) (
112455 118256 (COLORIZEBITMAP 112465 . 113397) (UNCOLORIZEBITMAP 113399 . 118254)) (118344 121607 (
COLORMENU 118354 . 121215) (CURSORCOLOR 121217 . 121605)) (124052 128341 (PSEUDOCOLOR 124062 . 126995)
 (\PSEUDOCOLOR.BITMAP 126997 . 127230) (\PSEUDOCOLOR.UFN 127232 . 128339)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/MAIKOCOLOR b/internal/library/OBSOLETE/MAIKOCOLOR
new file mode 100644
index 00000000..3a498f24
--- /dev/null
+++ b/internal/library/OBSOLETE/MAIKOCOLOR
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "15-Jun-90 17:42:22" |{DSK}<usr>local>lde>lispcore>internal>library>MAIKOCOLOR.;2| 25610  

      |changes| |to:|  (VARS MAIKOCOLORCOMS)

      |previous| |date:| "22-Mar-89 02:08:31" 
|{DSK}<usr>local>lde>lispcore>internal>library>MAIKOCOLOR.;1|)


; Copyright (c) 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT MAIKOCOLORCOMS)

(RPAQQ MAIKOCOLORCOMS
       ((P (MOVD? '\\SLOWBLTCHAR '\\OLD.SLOWBLTCHAR)
           (MOVD? 'CURSOREXIT 'OLD.CURSOREXIT)
           (MOVD? '\\SOFTCURSORUP '\\OLD.SOFTCURSORUP))
        (FNS \\MAIKO.COLORINIT \\MAIKO.STARTCOLOR \\MAIKO.STOPCOLOR \\MAIKO.EVENTFN 
             \\MAIKO.SENDCOLORMAPENTRY \\MAIKO.CHANGESCREEN)
        (FNS \\COLORDISPLAYBITS CURSOREXIT \\SLOWBLTCHAR \\SOFTCURSORUP)
        (MACROS \\MAIKO.CGFOURP \\MAIKO.CGTWOP)
        (CONSTANTS (\\TO.MAIKO.MONOSCREEN 0)
               (\\TO.MAIKO.COLORSCREEN 1)
               (\\MAIKO.COLORSCREENWIDTH 1152)
               (\\MAIKO.COLORSCREENHEIGHT 900)
               (\\MAIKO.COLORPAGES 2048)
               (\\MAIKO.COLORBUF.ALIGN 4095))
        (GLOBALVARS MAIKOCOLOR.BITSPERPIXEL)
        (INITVARS (\\MAIKO.CURRENT.SCREEN.MODE \\TO.MAIKO.MONOSCREEN))
        (FILES COLOR)
        (DECLARE\: DONTEVAL@LOAD DOCOPY (P (\\MAIKO.COLORINIT)))))

(MOVD? '\\SLOWBLTCHAR '\\OLD.SLOWBLTCHAR)

(MOVD? 'CURSOREXIT 'OLD.CURSOREXIT)

(MOVD? '\\SOFTCURSORUP '\\OLD.SOFTCURSORUP)
(DEFINEQ

(\\MAIKO.COLORINIT
  (LAMBDA NIL
    (DECLARE (GLOBALVARS \\MAIKOCOLORWSOPS \\MAIKOCOLORINFO))
                                                          (* \; "Edited  2-Nov-88 11:14 by shimizu")
    (SETQ \\MAIKOCOLORWSOPS (|create| WSOPS
                                   STARTBOARD _ (FUNCTION NILL)
                                   STARTCOLOR _ (FUNCTION \\MAIKO.STARTCOLOR)
                                   STOPCOLOR _ (FUNCTION NILL)
                                   EVENTFN _ (FUNCTION NILL)
                                   SENDCOLORMAPENTRY _ (FUNCTION \\MAIKO.SENDCOLORMAPENTRY)
                                   SENDPAGE _ (FUNCTION NILL)
                                   PILOTBITBLT _ (FUNCTION \\DISPLAY.PILOTBITBLT)))
    (SETQ \\MAIKOCOLORINFO (|create| DISPLAYINFO
                                  DITYPE _ 'MAIKOCOLOR
                                  DIWIDTH _ \\MAIKO.COLORSCREENWIDTH
                                  DIHEIGHT _ \\MAIKO.COLORSCREENHEIGHT
                                  DIBITSPERPIXEL _ 8
                                  DIWSOPS _ \\MAIKOCOLORWSOPS))
    (\\DEFINEDISPLAYINFO \\MAIKOCOLORINFO)))

(\\MAIKO.STARTCOLOR
  (LAMBDA (FDEV)                                      (* \; "Edited  2-Nov-88 11:13 by shimizu")
    (PROG (DISPLAYSTATE)
          (SETQ DISPLAYSTATE (|fetch| (FDEV DEVICEINFO) |of| FDEV))
          (|replace| (DISPLAYSTATE ONOFF) |of| DISPLAYSTATE |with| 'STARTCOLOR)
          (MOVD '\\DISPLAY.PILOTBITBLT '\\SOFTCURSORPILOTBITBLT)

     (* |;;| " MMAP colorbuffer")

          ((OPCODES SUBRCALL 136 1)
           (FETCH (BITMAP BITMAPBASE) OF |ColorScreenBitMap|))
          (|replace| (DISPLAYSTATE ONOFF) |of| DISPLAYSTATE |with| 'ON))))

(\\MAIKO.STOPCOLOR
  (LAMBDA (FDEV)                                      (* \; "Edited 12-Mar-89 20:02 by takeshi")
                                                             (* \; "By Take")
    (PROG (DISPLAYSTATE)
          (SETQ DISPLAYSTATE (|fetch| (FDEV DEVICEINFO) |of| FDEV))
          (|replace| (DISPLAYSTATE ONOFF) |of| DISPLAYSTATE |with| 'STOPCOLOR)
          (|replace| (DISPLAYSTATE ONOFF) |of| DISPLAYSTATE |with| 'OFF))))

(\\MAIKO.EVENTFN
  (LAMBDA (FDEV EVENT)                                (* \; "Edited 12-Mar-89 19:52 by takeshi")
                                                             (* \; "BY take")
    (COND
       ((EQ (|fetch| (DISPLAYSTATE ONOFF) |of| (|fetch| (FDEV DEVICEINFO) |of| FDEV))
            'ON)
        (SELECTQ EVENT
            ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS)       (* |turn| |off| |display| |since| 
                                                           |we| |may| |awake| |on| |different| 
                                                           |machine|)
                 (COLORDISPLAY 'OFF))
            (AFTERSAVEVM                                     (* |Rekick| |the| |color| 
                                                           |microcode.| *)
                         (\\MAIKO.STARTCOLOR \\COLORDISPLAYFDEV)
                         (SCREENCOLORMAP (SCREENCOLORMAP)))
            NIL)))))

(\\MAIKO.SENDCOLORMAPENTRY
  (LAMBDA (FDEV COLOR# RGB)                           (* \; "Edited  1-Dec-88 18:16 by shimizu")
    ((OPCODES SUBRCALL 138 4)
     COLOR#
     (CAR RGB)
     (CADR RGB)
     (CADDR RGB))))

(\\MAIKO.CHANGESCREEN
  (LAMBDA (TOSCREEN)                                  (* \; "Edited  1-Dec-88 18:32 by shimizu")
    ((OPCODES SUBRCALL 137 1)
     TOSCREEN)))
)
(DEFINEQ

(\\COLORDISPLAYBITS
  (LAMBDA (WIDTH HEIGHT BITSPERPIXEL)                 (* \; "Edited 22-Mar-89 02:07 by takeshi")
                                                             (* |returns| \a |pointer| |to| |the| 
                                                           |bits| |that| |the| |color| |board| 
                                                           |needs.|)
    (DECLARE (GLOBALVARS \\COLORDISPLAYBITS))
    (COND
       ((AND (EQ (MACHINETYPE)
                 'MAIKO)
             (OR (\\MAIKO.CGTWOP)
                 (\\MAIKO.CGFOURP)))
        (PROG ((DUMMY (\\ALLOCPAGEBLOCK 1))
               (ADDROFFSET ((OPCODES SUBRCALL 139 0))))
              (WHILE (NEQ (LOGAND \\MAIKO.COLORBUF.ALIGN (IPLUS (\\LOLOC DUMMY)
                                                                    ADDROFFSET))
                              0) DO (SETQ DUMMY (\\ALLOCPAGEBLOCK 1)))
              (RETURN (OR (SETQ \\COLORDISPLAYBITS (\\ALLOCPAGEBLOCK \\MAIKO.COLORPAGES))
                          (ERROR "No room for color screen of size" \\MAIKO.COLORPAGES)))))
       (T (PROG (NPAGES)

         (* TBW\: I\f |you| |come| |through| |this| |function| \a |second| |time| |with| 
       |different| |screen| |params| |won't| |you| |get| |screwed| |half| |the| 
       |time?| *)

                (COND
                   ((NULL \\COLORDISPLAYBITS)                (* 2 |extra| |pages| |needed| |for| 
                                                           DORADOCOLOR |microcode| |bug.|
                                                           *)
                    (SETQ NPAGES (IPLUS (FOLDHI (ITIMES (FOLDHI (ITIMES WIDTH BITSPERPIXEL)
                                                               BITSPERWORD)
                                                       HEIGHT)
                                               WORDSPERPAGE)
                                        2))                  (* \\ALLOCBLOCK |can't| |hack| 
                                                           |bitmaps| |of| |the| |size| |of| 
                                                           |the| 1132 |color| |screen|)
                    (SETQ \\COLORDISPLAYBITS (COND
                                                ((IGREATERP (UNFOLD NPAGES CELLSPERPAGE)
                                                        |\\MaxArrayNCells|)
                                                 (OR (\\ALLOCPAGEBLOCK NPAGES)
                                                     (ERROR "No room for color screen of size" NPAGES
                                                            )))
                                                (T (\\ALLOCBLOCK (UNFOLD NPAGES CELLSPERPAGE)
                                                          NIL NIL CELLSPERPAGE))))))
                (RETURN \\COLORDISPLAYBITS))))))

(CURSOREXIT
  (LAMBDA NIL                                         (* \; "Edited  2-Nov-88 13:11 by shimizu")

         (* * |called| |when| |cursor| |moves| |off| |the| |screen| |edge|)

    (DECLARE (GLOBALVARS LASTSCREEN LASTMOUSEX LASTMOUSEY \\MAIKO.CURRENT.SCREEN.MODE))
    (PROG (SCREEN XCOORD YCOORD SCREEN2 XCOORD2 YCOORD2)
          (SETQ SCREEN LASTSCREEN)
          (SETQ XCOORD LASTMOUSEX)
          (SETQ YCOORD LASTMOUSEY)
          (SETQ SCREEN2 (COND
                           ((EQ SCREEN \\MAINSCREEN)
                            (PROGN \\COLORSCREEN))
                           (T (PROGN \\MAINSCREEN))))        (* |generalize| |for| |more| |than| 
                                                           |two| |screens| (|or| |alternate| 
                                                           |physical| |arrangement| |of| 
                                                           |screens.|))
          (COND
             ((EQ XCOORD 0)
              (SETQ XCOORD2 (IDIFFERENCE (|fetch| (SCREEN SCWIDTH) |of| SCREEN2)
                                   2)))
             ((EQ XCOORD (SUB1 (|fetch| (SCREEN SCWIDTH) |of| SCREEN)))
              (SETQ XCOORD2 1))
             (T (RETURN)))
          (SETQ YCOORD2 (IQUOTIENT (ITIMES YCOORD (SUB1 (|fetch| (SCREEN SCHEIGHT) |of|
                                                                                       SCREEN2)))
                               (SUB1 (|fetch| (SCREEN SCHEIGHT) |of| SCREEN))))
          (CURSORSCREEN SCREEN2 XCOORD2 YCOORD2)
          (AND (EQUAL (MACHINETYPE)
                      'MAIKO)
               (COND
                  ((EQ \\MAIKO.CURRENT.SCREEN.MODE \\TO.MAIKO.MONOSCREEN)
                   (\\MAIKO.CHANGESCREEN \\TO.MAIKO.COLORSCREEN)
                   (SETQ \\MAIKO.CURRENT.SCREEN.MODE \\TO.MAIKO.COLORSCREEN))
                  (T (\\MAIKO.CHANGESCREEN \\TO.MAIKO.MONOSCREEN)
                     (SETQ \\MAIKO.CURRENT.SCREEN.MODE \\TO.MAIKO.MONOSCREEN)))))))

(\\SLOWBLTCHAR
  (LAMBDA (CHARCODE DISPLAYSTREAM)                    (* \; "Edited  7-Dec-88 13:00 by shimizu")

    (* |;;| "case of BLTCHAR where either font is rotated or destination is a color bitmap.  DISPLAYSTREAM is known to be a display stream, and its cache fields have been updated for CHARCODE's charset")

    (PROG (ROTATION CHAR8CODE DD FONTDESC)
          (SETQ CHAR8CODE (\\CHAR8CODE CHARCODE))
          (SETQ DD (|ffetch| (STREAM IMAGEDATA) |of| DISPLAYSTREAM))
          (SETQ FONTDESC (|ffetch| (\\DISPLAYDATA DDFONT) |of| DD))
          (SETQ ROTATION (|ffetch| (FONTDESCRIPTOR ROTATION) |of| FONTDESC))
          (COND
             ((EQ 0 ROTATION)
              (PROG (NEWX LEFT RIGHT CURX PILOTBBT DESTBIT WIDTH SOURCEBIT CSINFO)
                    (SETQ CSINFO (\\GETCHARSETINFO (\\CHARSET CHARCODE)
                                        (|ffetch| (\\DISPLAYDATA DDFONT) |of| DD)))
                    (SETQ CURX (|ffetch| (\\DISPLAYDATA DDXPOSITION) |of| DD))
                    (SETQ NEWX (IPLUS CURX (\\DSPGETCHARWIDTH CHAR8CODE DD)))
                    (COND
                       ((IGREATERP NEWX (|ffetch| (\\DISPLAYDATA |DDRightMargin|) |of| DD))
                                                             (* \; "past RIGHT margin, force eol")
                        (\\DSPPRINTCR/LF (CHARCODE EOL)
                               DISPLAYSTREAM)
                        (SETQ CURX (|ffetch| (\\DISPLAYDATA DDXPOSITION) |of| DD))
                        (SETQ NEWX (IPLUS CURX (\\DSPGETCHARWIDTH CHAR8CODE DD)))))
                                                             (* \; "update the x position.")
                    (|freplace| (\\DISPLAYDATA DDXPOSITION) |of| DD |with| NEWX)
                                                             (* SETQ CURX (\\DSPTRANSFORMX CURX 
                                                           DD))
                    (SETQ LEFT (IMAX (|ffetch| (\\DISPLAYDATA |DDClippingLeft|) |of| DD)
                                     CURX))
                    (SETQ RIGHT (IMIN (|ffetch| (\\DISPLAYDATA |DDClippingRight|) |of| DD)
                                      (\\DSPTRANSFORMX NEWX DD)))
                    (BITBLT (|ffetch| (CHARSETINFO CHARSETBITMAP) |of| CSINFO)
                           (\\DSPGETCHAROFFSET CHAR8CODE DD)
                           0 DISPLAYSTREAM CURX (ADD1 (IDIFFERENCE (|ffetch| (\\DISPLAYDATA
                                                                                  DDYPOSITION)
                                                                      |of| DD)
                                                             (|ffetch| (CHARSETINFO 
                                                                                  CHARSETDESCENT)
                                                                |of| CSINFO)))
                           (\\DSPGETCHARWIDTH CHAR8CODE DD)
                           (IPLUS (|ffetch| (CHARSETINFO CHARSETASCENT) |of| CSINFO)
                                  (|ffetch| (CHARSETINFO CHARSETDESCENT) |of| CSINFO)))
                                                             (* \; "(SETQ PILOTBBT (|ffetch| (\\\\DISPLAYDATA DDPILOTBBT) |of| DD)) (COND ((AND (ILESSP LEFT RIGHT) (NOT (EQ (|ffetch| (PILOTBBT PBTHEIGHT) |of| PILOTBBT) 0))) (SETQ DESTBIT LEFT) (SETQ WIDTH (IDIFFERENCE RIGHT LEFT)) (SETQ SOURCEBIT (IDIFFERENCE (IPLUS (\\\\DSPGETCHAROFFSET CHAR8CODE DD) LEFT) CURX)) (SELECTQ (|ffetch| (BITMAP BITMAPBITSPERPIXEL) |of| (|ffetch| (\\\\DISPLAYDATA |DDDestination|) |of| DD)) (1) (4 (SETQ DESTBIT (LLSH DESTBIT 2)) (SETQ WIDTH (LLSH WIDTH 2)) (SETQ SOURCEBIT (LLSH SOURCEBIT 2))) (8 (SETQ DESTBIT (LLSH DESTBIT 3)) (SETQ WIDTH (LLSH WIDTH 3)) (SETQ SOURCEBIT (LLSH SOURCEBIT 3))) (24 (SETQ DESTBIT (ITIMES 24 DESTBIT)) (SETQ WIDTH (ITIMES 24 WIDTH)) (SETQ SOURCEBIT (ITIMES 24 SOURCEBIT))) (SHOULDNT)) (.WHILE.TOP.DS. DISPLAYSTREAM (|freplace| (PILOTBBT PBTDESTBIT) |of| PILOTBBT |with| DESTBIT) (|freplace| (PILOTBBT PBTWIDTH) |of| PILOTBBT |with| WIDTH) (|freplace| (PILOTBBT PBTSOURCEBIT) |of| PILOTBBT |with| SOURCEBIT) (\\\\PILOTBITBLT PILOTBBT 0)) T))")
                ))
             (T                                              (* \; "handle rotated fonts")
                (PROG (YPOS HEIGHTMOVED CSINFO)
                      (SETQ YPOS (|ffetch| (\\DISPLAYDATA DDYPOSITION) |of| DD))
                      (SETQ HEIGHTMOVED (\\DSPGETCHARWIDTH CHAR8CODE DD))
                      (SETQ CSINFO (\\GETCHARSETINFO (\\CHARSET CHARCODE)
                                          (|ffetch| (\\DISPLAYDATA DDFONT) |of| DD)))
                      (COND
                         ((EQ ROTATION 90)                   (* \; 
                                                           "don't force CR for rotated fonts.")
                          (\\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED))
                                                             (* \; 
                                                           "update the display stream x position.")
                          (BITBLT (|ffetch| (CHARSETINFO CHARSETBITMAP) |of| CSINFO)
                                 0
                                 (\\DSPGETCHAROFFSET CHAR8CODE DD)
                                 DISPLAYSTREAM
                                 (ADD1 (IDIFFERENCE (|ffetch| (\\DISPLAYDATA DDXPOSITION)
                                                       |of| DD)
                                              (|ffetch| (CHARSETINFO CHARSETASCENT) |of|
                                                                                        CSINFO)))
                                 YPOS
                                 (IPLUS (|ffetch| (CHARSETINFO CHARSETASCENT) |of| CSINFO)
                                        (|ffetch| (CHARSETINFO CHARSETDESCENT) |of| CSINFO))
                                 HEIGHTMOVED))
                         ((EQ ROTATION 270)
                          (\\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED))
                          (BITBLT (|ffetch| (CHARSETINFO CHARSETBITMAP) |of| CSINFO)
                                 0
                                 (\\GETBASE (|ffetch| (\\DISPLAYDATA DDOFFSETSCACHE) |of|
                                                                                         DD)
                                        CHAR8CODE)
                                 DISPLAYSTREAM
                                 (IDIFFERENCE (|ffetch| (\\DISPLAYDATA DDXPOSITION) |of|
                                                                                        DD)
                                        (|ffetch| (CHARSETINFO CHARSETDESCENT) |of| CSINFO))
                                 (|ffetch| (\\DISPLAYDATA DDYPOSITION) |of| DISPLAYSTREAM)
                                 (IPLUS (|ffetch| (CHARSETINFO CHARSETASCENT) |of| CSINFO)
                                        (|ffetch| (CHARSETINFO CHARSETDESCENT) |of| CSINFO))
                                 HEIGHTMOVED))
                         (T (ERROR "Not implemented to rotate by other than 0, 90 or 270")))))))))

(\\SOFTCURSORUP
  (LAMBDA (NEWCURSOR)                                 (* \; "Edited 16-Jan-89 15:44 by shimizu")
                                                             (* |Put| |soft| NEWCURSOR |up,| 
                                                           |assuming| |soft| |cursor| |is| 
                                                           |down.| *)
    (COND
       ((EQ \\MACHINETYPE \\MAIKO)
        (SETQ \\CURRENTCURSOR NEWCURSOR))
       (T (PROG (IMAGE MASK WIDTH BWIDTH HEIGHT CURSORBITSPERPIXEL CURSORBPL UPBMBASE DOWNBMBASE)
                                                             (* |Get| |cursor| IMAGE & MASK.
                                                           *)
                (SETQ IMAGE (|fetch| (CURSOR CUIMAGE) |of| NEWCURSOR))
                (SETQ MASK (|fetch| (CURSOR CUMASK) |of| NEWCURSOR))
                (SETQ WIDTH (|fetch| (BITMAP BITMAPWIDTH) |of| IMAGE))
                (SETQ HEIGHT (|fetch| (BITMAP BITMAPHEIGHT) |of| IMAGE))
                (SETQ CURSORBITSPERPIXEL (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| IMAGE))
                                                             (* |Create| |new| UPBM & DOWNBM 
                                                           |caches| |if| |necessary.|
                                                           *)
                (COND
                   ((NOT (AND (|type?| BITMAP \\SOFTCURSORUPBM)
                              (EQ (|fetch| (BITMAP BITMAPWIDTH) |of| \\SOFTCURSORUPBM)
                                  WIDTH)
                              (EQ (|fetch| (BITMAP BITMAPHEIGHT) |of| \\SOFTCURSORUPBM)
                                  HEIGHT)
                              (EQ (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| \\SOFTCURSORUPBM)
                                  CURSORBITSPERPIXEL)))
                    (SETQ \\SOFTCURSORWIDTH WIDTH)
                    (SETQ \\SOFTCURSORHEIGHT HEIGHT)
                    (SETQ \\SOFTCURSORUPBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL))
                    (SETQ \\SOFTCURSORDOWNBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL))
                    (SETQ UPBMBASE (|fetch| (BITMAP BITMAPBASE) |of| \\SOFTCURSORUPBM))
                    (\\TEMPLOCKPAGES UPBMBASE 1)
                    (SETQ DOWNBMBASE (|fetch| (BITMAP BITMAPBASE) |of| \\SOFTCURSORDOWNBM))
                    (\\TEMPLOCKPAGES DOWNBMBASE 1)
                    (SETQ CURSORBPL (UNFOLD (|fetch| (BITMAP BITMAPRASTERWIDTH) |of| IMAGE)
                                           BITSPERWORD))
                    (SETQ BWIDTH (ITIMES (|fetch| (BITMAP BITMAPWIDTH) |of| IMAGE)
                                        (|fetch| (BITMAP BITMAPBITSPERPIXEL) |of| IMAGE)))
                    (|replace| (PILOTBBT PBTDESTBPL) |of| \\SOFTCURSORBBT1 |with| 
                                                                                         CURSORBPL)
                    (|replace| (PILOTBBT PBTDEST) |of| \\SOFTCURSORBBT2 |with| UPBMBASE)
                    (|replace| (PILOTBBT PBTDESTBPL) |of| \\SOFTCURSORBBT2 |with| 
                                                                                         CURSORBPL)
                    (|replace| (PILOTBBT PBTSOURCE) |of| \\SOFTCURSORBBT2 |with| 
                                                                                        DOWNBMBASE)
                    (|replace| (PILOTBBT PBTSOURCEBPL) |of| \\SOFTCURSORBBT2 |with|
                                                                                     CURSORBPL)
                    (|replace| (PILOTBBT PBTWIDTH) |of| \\SOFTCURSORBBT2 |with| BWIDTH)
                    (|replace| (PILOTBBT PBTHEIGHT) |of| \\SOFTCURSORBBT2 |with| HEIGHT)
                    (|replace| (PILOTBBT PBTDEST) |of| \\SOFTCURSORBBT3 |with| UPBMBASE)
                    (|replace| (PILOTBBT PBTDESTBPL) |of| \\SOFTCURSORBBT3 |with| 
                                                                                         CURSORBPL)
                    (|replace| (PILOTBBT PBTSOURCEBPL) |of| \\SOFTCURSORBBT3 |with|
                                                                                     CURSORBPL)
                    (|replace| (PILOTBBT PBTWIDTH) |of| \\SOFTCURSORBBT3 |with| BWIDTH)
                    (|replace| (PILOTBBT PBTHEIGHT) |of| \\SOFTCURSORBBT3 |with| HEIGHT)
                    (|replace| (PILOTBBT PBTDEST) |of| \\SOFTCURSORBBT4 |with| UPBMBASE)
                    (|replace| (PILOTBBT PBTDESTBPL) |of| \\SOFTCURSORBBT4 |with| 
                                                                                         CURSORBPL)
                    (|replace| (PILOTBBT PBTSOURCEBPL) |of| \\SOFTCURSORBBT4 |with|
                                                                                     CURSORBPL)
                    (|replace| (PILOTBBT PBTWIDTH) |of| \\SOFTCURSORBBT4 |with| BWIDTH)
                    (|replace| (PILOTBBT PBTHEIGHT) |of| \\SOFTCURSORBBT4 |with| HEIGHT)
                    (|replace| (PILOTBBT PBTSOURCEBPL) |of| \\SOFTCURSORBBT5 |with|
                                                                                     CURSORBPL)
                    (|replace| (PILOTBBT PBTSOURCEBPL) |of| \\SOFTCURSORBBT6 |with|
                                                                                     CURSORBPL)))
                                                             (* |Change| PILOTBBT\s.
                                                           *)
                (|replace| (PILOTBBT PBTSOURCE) |of| \\SOFTCURSORBBT3
                   |with| (|fetch| (BITMAP BITMAPBASE) |of| MASK))
                (|replace| (PILOTBBT PBTSOURCE) |of| \\SOFTCURSORBBT4
                   |with| (|fetch| (BITMAP BITMAPBASE) |of| IMAGE))
                                                             (* |Put| |up| |new| \\CURRENTCURSOR.
                                                           *)
                (SETQ \\CURRENTCURSOR NEWCURSOR)
                (\\TEMPLOCKPAGES \\CURRENTCURSOR 1)
                (SETQ \\SOFTCURSORP T)
                (\\SOFTCURSORUPCURRENT))))))
)
(DECLARE\: EVAL@COMPILE 

(PUTPROPS \\MAIKO.CGFOURP MACRO (NIL (EQ (LOGAND 120 (|fetch| DEVCONFIG |of| 
                                                                                    |\\InterfacePage|
                                                                    ))
                                                 64)))

(PUTPROPS \\MAIKO.CGTWOP MACRO (NIL (EQ (LOGAND 120 (|fetch| DEVCONFIG |of| 
                                                                                    |\\InterfacePage|
                                                                   ))
                                                24)))
)
(DECLARE\: EVAL@COMPILE 

(RPAQQ \\TO.MAIKO.MONOSCREEN 0)

(RPAQQ \\TO.MAIKO.COLORSCREEN 1)

(RPAQQ \\MAIKO.COLORSCREENWIDTH 1152)

(RPAQQ \\MAIKO.COLORSCREENHEIGHT 900)

(RPAQQ \\MAIKO.COLORPAGES 2048)

(RPAQQ \\MAIKO.COLORBUF.ALIGN 4095)


(CONSTANTS (\\TO.MAIKO.MONOSCREEN 0)
       (\\TO.MAIKO.COLORSCREEN 1)
       (\\MAIKO.COLORSCREENWIDTH 1152)
       (\\MAIKO.COLORSCREENHEIGHT 900)
       (\\MAIKO.COLORPAGES 2048)
       (\\MAIKO.COLORBUF.ALIGN 4095))
)
(DECLARE\: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS MAIKOCOLOR.BITSPERPIXEL)
)

(RPAQ? \\MAIKO.CURRENT.SCREEN.MODE \\TO.MAIKO.MONOSCREEN)

(FILESLOAD COLOR)
(DECLARE\: DONTEVAL@LOAD DOCOPY 

(\\MAIKO.COLORINIT)
)
(PUTPROPS MAIKOCOLOR COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (1501 5202 (\\MAIKO.COLORINIT 1511 . 2684) (\\MAIKO.STARTCOLOR 2686 . 3306) (
\\MAIKO.STOPCOLOR 3308 . 3797) (\\MAIKO.EVENTFN 3799 . 4791) (\\MAIKO.SENDCOLORMAPENTRY 4793 . 5021) (
\\MAIKO.CHANGESCREEN 5023 . 5200)) (5203 24135 (\\COLORDISPLAYBITS 5213 . 8105) (CURSOREXIT 8107 . 
10172) (\\SLOWBLTCHAR 10174 . 17604) (\\SOFTCURSORUP 17606 . 24133)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/MAIKOCOLOR.TEdit b/internal/library/OBSOLETE/MAIKOCOLOR.TEdit
new file mode 100644
index 00000000..56d4e665
Binary files /dev/null and b/internal/library/OBSOLETE/MAIKOCOLOR.TEdit differ
diff --git a/internal/library/OBSOLETE/READINTERPRESS b/internal/library/OBSOLETE/READINTERPRESS
new file mode 100644
index 00000000..2c02ea90
--- /dev/null
+++ b/internal/library/OBSOLETE/READINTERPRESS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "26-Jun-90 18:59:13" {DSK}<usr>local>lde>lispcore>internal>library>READINTERPRESS.;2 16698  

      changes to%:  (VARS READINTERPRESSCOMS)

      previous date%: " 5-Jan-89 17:42:57" 
{DSK}<usr>local>lde>lispcore>internal>library>READINTERPRESS.;1)


(* ; "
Copyright (c) 1983, 1984, 1985, 1986, 1988, 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT READINTERPRESSCOMS)

(RPAQQ READINTERPRESSCOMS
       [(* "Utilities for reading Interpress files")
        (FNS PRINTMASTER)
        (FNS OPCODE TOKEN FINDNONPRIMNAME FINDOPNAME SHORTINT TOKENFORMAT FINDSEQUENCETYPE PRINTTOKEN
             PRINTSEQUENCE SEARCHIPLIST READINT.IP SHOWFILE SHOWBYTE)
        (MACROS BIN.RIP)
        (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
                                                INTERPRESS))
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA SHORTINT TOKEN])



(* "Utilities for reading Interpress files")

(DEFINEQ

(PRINTMASTER
  [LAMBDA (FILE OUTPUTFILE FROM TO)                     (* ; "Edited  1-Dec-88 12:51 by Briggs")
    (RESETLST
        (PROG (ISTREAM)
              [RESETSAVE (SETQ ISTREAM (OPENSTREAM FILE 'INPUT))
                     '(PROGN (CLOSEF OLDVALUE]
              [COND
                 (OUTPUTFILE (RESETSAVE (SETQ OUTPUTFILE (OPENSTREAM OUTPUTFILE 'OUTPUT))
                                    '(PROGN (CLOSEF OLDVALUE)
                                            (AND RESETSTATE (DELFILE OLDVALUE]
                                                             (* Print the encoding string)
              (bind C until (EQ (SETQ C (BIN ISTREAM))
                                        (CHARCODE SPACE)) do (PRINTCCODE C OUTPUTFILE))
              (TERPRI OUTPUTFILE)
              (SETFILEPTR ISTREAM (IMAX (\GETFILEPTR ISTREAM)
                                        (OR FROM 0)))
              (until (OR (EOFP ISTREAM)
                             (AND TO (IGEQ (\GETFILEPTR ISTREAM)
                                           TO))) do (printout OUTPUTFILE |.I5| (GETFILEPTR 
                                                                                          ISTREAM)
                                                               "|" 8)
                                                       (PRINTTOKEN ISTREAM OUTPUTFILE))))])
)
(DEFINEQ

(OPCODE
  [LAMBDA (BYTE1 BYTE2)                                  (* rmk%: "19-APR-83 17:51")
    (FINDOPNAME (IPLUS (LLSH (LOGAND BYTE1 31)
                                 8)
                           (OR BYTE2 0])

(TOKEN
  [LAMBDA BYTES                                          (* edited%: "20-APR-83 10:06")
    (COND
       ((ZEROP BYTES)
        NIL)
       ((NLISTP (ARG BYTES 1))
        (APPLY (FUNCTION TOKEN)
               (ARG BYTES 1)))
       (T (SELECTQ (TOKENFORMAT (ARG BYTES 1))
              (SHORTINT (APPLY (FUNCTION SHORTINT)
                               (for I from 1 to BYTES collect (ARG BYTES I))))
              (SHORTOP (FINDOPNAME (LOGAND (ARG BYTES 1)
                                              31)))
              (LONGOP (FINDOPNAME (IPLUS (LLSH (LOGAND (ARG BYTES 1)
                                                          31)
                                                   8)
                                             (OR (ARG BYTES 2)
                                                 0))))
              (SHORTSEQUENCE [PROG [LEN (TYPE (FINDSEQUENCETYPE (LOGAND (ARG BYTES 1)
                                                                           31]
                                   (COND
                                      ((IGREATERP BYTES 0)
                                       (SETQ LEN (ARG BYTES 2])
              (LONGSEQUENCE)
              (SHOULDNT])

(FINDNONPRIMNAME
  [LAMBDA (CODE)                                         (* rmk%: "15-Mar-84 09:07")
    (SEARCHIPLIST CODE (CONSTANT NONPRIMS])

(FINDOPNAME
  [LAMBDA (CODE)                                         (* rmk%: "16-Jun-84 15:24")
    (SEARCHIPLIST CODE (CONSTANT (for OP DOTLOC in OPERATORS
                                        collect          (* Strip off extension)
                                              (COND
                                                 ((SETQ DOTLOC (STRPOS "." (CAR OP)))
                                                  (LIST (SUBATOM (CAR OP)
                                                               1
                                                               (SUB1 DOTLOC))
                                                        (CADR OP)))
                                                 (T OP])

(SHORTINT
  [LAMBDA BYTES                                          (* rmk%: "19-APR-83 17:34")
    (for I (RESULT _ 0) from 1 to BYTES do (SETQ RESULT (LOGOR (LLSH RESULT 8)
                                                                               (ARG BYTES I)))
       finally (RETURN (IDIFFERENCE RESULT 4000])

(TOKENFORMAT
  [LAMBDA (BYTE)                                         (* rmk%: "19-APR-83 17:41")
    (SELECTQ (LRSH BYTE 7)
        (0 'SHORTINT)
        (SELECT (LOGAND (LRSH BYTE 5)
                       3)
               (0 'SHORTOP)
               (1 'LONGOP)
               (2 'SHORTSEQUENCE)
               (3 'LONGSEQUENCE)
               (SHOULDNT])

(FINDSEQUENCETYPE
  [LAMBDA (CODE)                                         (* rmk%: "15-Mar-84 09:04")
    (for X in (CONSTANT SEQUENCETYPES) when (EQ CODE (CADR X))
       do (RETURN (CAR X)) finally (RETURN (LIST CODE 'NOT-A-SEQUENCE-TYPE])

(PRINTTOKEN
  [LAMBDA (ISTREAM OSTREAM)                              (* hdj "15-Jul-86 21:55")
    (PROG (CODE BYTE2 (BYTE1 (BIN.RIP ISTREAM OSTREAM)))
          (SELECTQ (TOKENFORMAT BYTE1)
              (SHORTINT (SETQ BYTE2 (BIN.RIP ISTREAM OSTREAM))
                        (printout OSTREAM .TAB 20)
                        (PRINT (SHORTINT BYTE1 BYTE2)
                               OSTREAM))
              (SHORTOP (SETQ CODE (LOGAND BYTE1 31))
                       (printout OSTREAM .TAB 20)
                       (printout OSTREAM (OR (FINDOPNAME CODE)
                                             (FINDNONPRIMNAME CODE)
                                             (CONCAT CODE "not an opcode"))
                              T))
              (LONGOP (SETQ CODE (IPLUS (LLSH (LOGAND BYTE1 31)
                                              8)
                                        (BIN.RIP ISTREAM OSTREAM)))
                      (printout OSTREAM .TAB 20)
                      (printout OSTREAM (OR (FINDOPNAME CODE)
                                            (FINDNONPRIMNAME CODE)
                                            (CONCAT CODE "not an opcode"))
                             T))
              (SHORTSEQUENCE (PRINTSEQUENCE ISTREAM OSTREAM (FINDSEQUENCETYPE (LOGAND BYTE1 
                                                                                             31))
                                    (BIN.RIP ISTREAM OSTREAM)))
              (LONGSEQUENCE (PRINTSEQUENCE ISTREAM OSTREAM (FINDSEQUENCETYPE (LOGAND BYTE1 31
                                                                                            ))
                                   (LOGOR (LLSH (BIN.RIP ISTREAM OSTREAM)
                                                16)
                                          (LLSH (BIN.RIP ISTREAM OSTREAM)
                                                8)
                                          (BIN.RIP ISTREAM OSTREAM))))
              (SHOULDNT])

(PRINTSEQUENCE
  [LAMBDA (ISTREAM OUTSTREAM TYPE LENGTH)                (* ; "Edited  5-Jan-89 11:13 by jds")
    (SELECTQ TYPE
        (SEQIDENTIFIER (printout OUTSTREAM 20 "ID:  ")
                       (CHARSET ISTREAM 0)
                       (bind (CHARSET _ 0) until (ILEQ LENGTH 0)
                          do (PRINTCCODE (\NSIN ISTREAM CHARSET CHARSET LENGTH)
                                        OUTSTREAM)))
        (SEQINTEGER (PROG ((NUM (READINT.IP ISTREAM OUTSTREAM LENGTH)))
                          (printout OUTSTREAM 20 NUM)))
        (SEQRATIONAL (PROG [(NUM (READINT.IP ISTREAM OUTSTREAM (LRSH LENGTH 1)))
                            (DENOM (READINT.IP ISTREAM OUTSTREAM (LRSH LENGTH 1]
                           (printout OUTSTREAM 20 NUM "/" DENOM " = " (FQUOTIENT NUM DENOM))))
        (SEQSTRING (printout OUTSTREAM 20 "STR[" LENGTH "] = %"")
                   (CHARSET ISTREAM 0)
                   (bind (CHARSET _ 0) until (ILEQ LENGTH 0)
                      do (PRINTCCODE (\NSIN ISTREAM CHARSET CHARSET LENGTH)
                                    OUTSTREAM))
                   (printout OUTSTREAM '%"))
        (SEQCOMMENT (for I from 1 to LENGTH
                       first (printout OUTSTREAM 20 "Comment vector of " LENGTH " bytes" 22)
                       do (printout OUTSTREAM |.I4| (BIN ISTREAM))))
        (SEQPACKEDPIXELVECTOR 
             (bind YBYTES (I _ 5)
                    (XBITS _ (READINT.IP ISTREAM OUTSTREAM 2))
                    (YBITS _ (READINT.IP ISTREAM OUTSTREAM 2))
                first (printout OUTSTREAM 20 "Packed pixel" " vector of " LENGTH " bytes [" XBITS
                                 "X" YBITS "]")
                      (SETQ YBYTES (UNFOLD (FOLDHI YBITS BITSPERWORD)
                                          BYTESPERWORD))     (* ; 
                            "The number of bytes on a line is always even--gets to a word boundary")
                while (ILEQ I LENGTH) do (printout OUTSTREAM T 10)
                                                (for J from 1 to YBYTES
                                                   do (printout OUTSTREAM |.I8.-2.T| (BIN ISTREAM
                                                                                              ))
                                                         (add I 1))))
        (SEQLARGEVECTOR 
             (for I VAL (BYTESPERELT _ (BIN ISTREAM)) from 2 to LENGTH
                first (printout OUTSTREAM 20 "Large vector of " BYTESPERELT " bytes per element")
                do (SETQ VAL (READINT.IP ISTREAM OUTSTREAM BYTESPERELT))
                      (printout OUTSTREAM 22 |.I5| I ":  " VAL)))
        (SEQCONTINUED (HELP "Can't handle SEQCONTINUED yet"))
        (SEQINSERTFILE (HELP "Can't handle SEQINSERTFILE yet"))
        (SEQCOMPRESSPIXELVECTOR 
             (HELP "Can't handle SEQCOMPRESSPIXELVECTOR yet"))
        (SHOULDNT))
    (TERPRI OUTSTREAM])

(SEARCHIPLIST
  [LAMBDA (CODE IPLIST)                                  (* rmk%: "15-Mar-84 09:15")
    (for X in IPLIST when (EQ CODE (CADR X)) do (RETURN (CAR X])

(READINT.IP
  [LAMBDA (ISTREAM OSTREAM NBYTES)                       (* ; "Edited 31-Mar-88 16:56 by jds")
          (* ;; "Read an integer (of NBYTES length), printing out byte values as you go.")

    (for I (RESULT _ 0) from 1 to NBYTES do (SETQ RESULT (LOGOR (LLSH RESULT 8)
                                                                                (BIN.RIP ISTREAM 
                                                                                       OSTREAM)))
       finally (RETURN (SIGNED RESULT (UNFOLD NBYTES BITSPERBYTE])

(SHOWFILE
  [LAMBDA (IPFILE OUTPUTFILE MAXZEROLINES)               (* rmk%: "16-Jun-84 15:29")
    (OR MAXZEROLINES (SETQ MAXZEROLINES 5))
    (RESETLST (PROG (STREAM)
                    [RESETSAVE (SETQ STREAM (OPENFILE IPFILE 'INPUT))
                           '(PROGN (CLOSEF? OLDVALUE]
                    (SETQ STREAM (GETSTREAM STREAM))
          (* Don't do an OPENSTREAM until (OPENP stream) is NIL if stream is closed.)
                    (RESETSAVE (OUTPUT))
                    [RESETSAVE (SETQ OUTPUTFILE (OPENFILE OUTPUTFILE 'OUTPUT))
                           '(PROGN (CLOSEF? OLDVALUE)
                                   (AND RESETSTATE (DELFILE OLDVALUE]
                    (OUTPUT OUTPUTFILE)
                    (printout NIL .FONT DEFAULTFONT (OPENP STREAM 'INPUT)
                           T T)
                    [for I B1 B2 B3 B4 B5 B6 B7 B8 (NZEROLINES _ 0) from 1 by 8
                       until (\EOFP STREAM) do (printout NIL |.I5| I %,,)
                                                      (SETQ B1 (SHOWBYTE STREAM))
                                                      (SETQ B2 (SHOWBYTE STREAM))
                                                      (SETQ B3 (SHOWBYTE STREAM))
                                                      (SETQ B4 (SHOWBYTE STREAM))
                                                      (printout NIL %,,)
                                                      (SETQ B5 (SHOWBYTE STREAM))
                                                      (SETQ B6 (SHOWBYTE STREAM))
                                                      (SETQ B7 (SHOWBYTE STREAM))
                                                      (SETQ B8 (SHOWBYTE STREAM))
                                                      (TAB 23)
                                                      (COND
                                                         (B1 (printout NIL |.I4| B1)))
                                                      (COND
                                                         (B2 (printout NIL |.I4| B2)))
                                                      (COND
                                                         (B3 (printout NIL |.I4| B3)))
                                                      (COND
                                                         (B4 (printout NIL |.I4| B4)))
                                                      (printout NIL %,,)
                                                      (COND
                                                         (B5 (printout NIL |.I4| B5)))
                                                      (COND
                                                         (B6 (printout NIL |.I4| B6)))
                                                      (COND
                                                         (B7 (printout NIL |.I4| B7)))
                                                      (COND
                                                         (B8 (printout NIL |.I4| B8 T]
                    (RETURN (LIST (CLOSEF IPFILE)
                                  (CLOSEF OUTPUTFILE])

(SHOWBYTE
  [LAMBDA (STREAM)                                       (* rmk%: "13-JUL-82 18:01")
    (PROG [(BYTE (COND
                    ((NOT (\EOFP STREAM))
                     (\BIN STREAM]
          [COND
             (BYTE (PRIN1 (COND
                             ((AND (IGEQ BYTE (CHARCODE SPACE))
                                   (ILESSP BYTE (CHARCODE DEL))
                                   (NEQ BYTE 96))
                              (CHARACTER BYTE))
                             (T '%.]
          (RETURN BYTE])
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS BIN.RIP MACRO [ARGS (LET ((ISTREAM (CAR ARGS))
                                            (OSTREAM (CADR ARGS)))
                                           `(LET [(C (BIN ,ISTREAM]
                                                 (COND
                                                    ((IGREATERP (POSITION ,OSTREAM)
                                                            15)
                                                     (printout ,OSTREAM 5 "|" 8)))
                                                 (printout ,OSTREAM |.I3| C " ")
                                                 C])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 

(FILESLOAD (LOADCOMP)
       INTERPRESS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA SHORTINT TOKEN)
)
(PUTPROPS READINTERPRESS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1249 2653 (PRINTMASTER 1259 . 2651)) (2654 15701 (OPCODE 2664 . 2896) (TOKEN 2898 . 
4148) (FINDNONPRIMNAME 4150 . 4311) (FINDOPNAME 4313 . 5063) (SHORTINT 5065 . 5415) (TOKENFORMAT 5417
 . 5788) (FINDSEQUENCETYPE 5790 . 6064) (PRINTTOKEN 6066 . 8120) (PRINTSEQUENCE 8122 . 11193) (
SEARCHIPLIST 11195 . 11386) (READINT.IP 11388 . 11965) (SHOWFILE 11967 . 15155) (SHOWBYTE 15157 . 
15699)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/RS232TEST b/internal/library/OBSOLETE/RS232TEST
new file mode 100644
index 00000000..44fbfdea
--- /dev/null
+++ b/internal/library/OBSOLETE/RS232TEST
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "26-Jun-90 19:15:35" |{DSK}<usr>local>lde>lispcore>internal>library>RS232TEST.;2| 9419   

      |changes| |to:|  (VARS RS232TESTCOMS)

      |previous| |date:| "20-Feb-87 00:10:14" 
|{DSK}<usr>local>lde>lispcore>internal>library>RS232TEST.;1|)


; Copyright (c) 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT RS232TESTCOMS)

(RPAQQ RS232TESTCOMS
       ((FNS RSTEST TESTCLEANUP XMITTEST)
        
        (* |;;| 
      "Exhaustive test for RS-232 for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")

        (FNS RS232.TEST RS232.MICROTEST RS232.QUICKTEST RS232.MENU RS232TMENU.SELFN)
        (VARS RS232.TEST.MENU.ITEMS)
        
        (* |;;| 
   "Exhaustive test for the TTY port for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")

        (FNS TTY.TEST TTY.MICROTEST TTY.QUICKTEST TTY.MENU TTYTMENU.SELFN)))
(DEFINEQ

(rstest
  (lambda nil                                                (* \; "Edited 14-Jan-87 16:00 by jds")
    (let (oo)
         (resetlst (resetsave (setq oo (openstream '{rs232} 'output))
                          'closef?)
                (|for| i |from| 1 |do| (printout oo "Line " i 
                                              ":  1 2 3 4 5 6 7 8 9 0 9 8 7 6 5 4 3 2 1.
\
")
                                       (printout t "Line " i t))))))

(testcleanup
  (lambda nil                                                (* \; "Edited 16-Jan-87 09:51 by jds")
          
          (* |;;| "Close the streams used by the rs232 test.")

    (and (boundp 'out)
         out
         (closef? out))
    (and (boundp in)
         in
         (closef? in))))

(XMITTEST
  (LAMBDA (BAUDRATE XONXOFF?)                                (* \; "Edited 19-Feb-87 20:59 by jds")
          
          (* |;;| "Set up the rs232 port at BAUDRATE with XOn-XOff flow control if XONXOFF? is T.  Then print forever, lines of text.  Show an indication on the screen for each line, so the user can tell if flow control has shut things off.")

    (RS232C.INIT BAUDRATE 8 'NONE 1 (COND
                                       (XONXOFF? 'XONXOFF)
                                       (T 'NONE)))
    (SETQ OUT (OPENSTREAM '{RS232} 'OUTPUT))
    (SETQ IN (OPENSTREAM '{RS232} 'INPUT))
    (ERSETQ (FOR I FROM 1 DO (PRINTOUT OUT "Line " I ":  0 1 2 3 4 5 6 7 8 9 0 9 8 7 6 5 4 3 2 1.
\
")
                             (|printout| T "Line " I T)))
    (CLOSEF? OUT)
    (CLOSEF? IN)))
)



(* |;;| "Exhaustive test for RS-232 for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")

(DEFINEQ

(rs232.test
  (lambda nil                                                (* \; "Edited 19-Feb-87 22:43 by jds")
          
          (* |;;| "Run quickly thru all the possible combinations of RS-232 bit lengths and parities and stop bits for testing sake.")

    (printout t t t "Starting RS-232 port test." t 
           "Make sure the line monitor is attached to the RS-232 port, " 
           "and its cable goes to the DCE socket on the monitor." t)
    (mouseconfirm)
    (printout t "Set the line monitor for: " t)
    (|for| bits |in| '(5 6 7 8) |do| (|for| parity |in| '(none odd even)
                                        |do| (|for| stopbits |in| '(1 1.5 2)
                                                |do| (rs232.microtest 9600 bits parity stopbits))))))

(rs232.microtest
  (lambda (speed bits parity stopbits)                       (* \; "Edited 19-Feb-87 22:37 by jds")
          
          (* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")

    (printout t bits "bits, " (cond
                                 ((eq parity 'none)
                                  "NO")
                                 (t parity))
           " parity, " stopbits " stop bits..." t)
    (mouseconfirm)
    (rs232.quicktest speed bits parity stopbits)))

(rs232.quicktest
  (lambda (speed bits parity stopbits)                       (* \; "Edited 19-Feb-87 22:38 by jds")
          
          (* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")

    (rs232c.init speed bits parity stopbits 'none)
    (let ((out (openstream '{rs232} 'output)))
         (prin1 (concat "0123 ABC abc " (packc '(1 2 3 255)))
                out)
         (closef out))))

(rs232.menu
  (lambda nil                                                (* \; "Edited 19-Feb-87 22:45 by jds")
    (let ((ww (addmenu (|create| menu
                              menucolumns _ 4
                              items _ rs232.test.menu.items
                              whenselectedfn _ (function rs232tmenu.selfn)))))
         (windowprop ww 'title "RS-232 Tests"))))

(rs232tmenu.selfn
  (lambda (item menu key)                                    (* \; "Edited 19-Feb-87 22:57 by jds")
          
          (* |;;| "Called from the RS-232 test menu")

    (let* ((info (cadr item))
           (bits (car info))
           (parity (cadr info))
           (stopbits (caddr info)))
          (rs232.quicktest 9600 bits parity stopbits))))
)

(RPAQQ RS232.TEST.MENU.ITEMS
       ((|5/N/1| (5 NONE 1))
        (|6/N/1| (6 NONE 1))
        (|7/N/1| (7 NONE 1))
        (|8/N/1| (8 NONE 1))
        (|5/N/1.5| (5 NONE 1.5))
        (|6/N/1.5| (6 NONE 1.5))
        (|7/N/1.5| (7 NONE 1.5))
        (|8/N/1.5| (8 NONE 1.5))
        (|5/N/2| (5 NONE 2))
        (|6/N/2| (6 NONE 2))
        (|7/N/2| (7 NONE 2))
        (|8/N/2| (8 NONE 2))
        (|5/O/1| (5 ODD 1))
        (|6/O/1| (6 ODD 1))
        (|7/O/1| (7 ODD 1))
        (|8/O/1| (8 ODD 1))
        (|5/O/1.5| (5 ODD 1.5))
        (|6/O/1.5| (6 ODD 1.5))
        (|7/O/1.5| (7 ODD 1.5))
        (|8/O/1.5| (8 ODD 1.5))
        (|5/O/2| (5 ODD 2))
        (|6/O/2| (6 ODD 2))
        (|7/O/2| (7 ODD 2))
        (|8/O/2| (8 ODD 2))
        (|5/E/1| (5 EVEN 1))
        (|6/E/1| (6 EVEN 1))
        (|7/E/1| (7 EVEN 1))
        (|8/E/1| (8 EVEN 1))
        (|5/E/1.5| (5 EVEN 1.5))
        (|6/E/1.5| (6 EVEN 1.5))
        (|7/E/1.5| (7 EVEN 1.5))
        (|8/E/1.5| (8 EVEN 1.5))
        (|5/E/2| (5 EVEN 2))
        (|6/E/2| (6 EVEN 2))
        (|7/E/2| (7 EVEN 2))
        (|8/E/2| (8 EVEN 2))))



(* |;;| 
"Exhaustive test for the TTY port for 5- 6- 7- and 8-bit chars, with parity NONE, EVEN, and ODD")

(DEFINEQ

(tty.test
  (lambda nil                                                (* \; "Edited 19-Feb-87 22:42 by jds")
          
          (* |;;| "Run quickly thru all the possible combinations of RS-232 bit lengths and parities and stop bits for testing sake.")

    (printout t t t "Starting TTY port test." t 
           "Make sure the line monitor is attached to the TTY port, " 
           "and its cable goes to the DTE socket on the monitor." t)
    (mouseconfirm)
    (printout t "Set the line monitor for: " t)
    (|for| bits |in| '(5 6 7 8) |do| (|for| parity |in| '(none odd even)
                                        |do| (|for| stopbits |in| '(1 1.5 2)
                                                |do| (tty.microtest 9600 bits parity stopbits))))))

(tty.microtest
  (lambda (speed bits parity stopbits)                       (* \; "Edited 19-Feb-87 22:41 by jds")
          
          (* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")

    (printout t bits "bits, " (cond
                                 ((eq parity 'none)
                                  "NO")
                                 (t parity))
           " parity, " stopbits " stop bits..." t)
    (mouseconfirm)
    (tty.init speed bits parity stopbits)))

(tty.quicktest
  (lambda (speed bits parity stopbits)                       (* \; "Edited 19-Feb-87 22:40 by jds")
          
          (* |;;| "Transmit a short test pattern to the RS232 port at SPEED baud, using BITS-bit characters, with PARITY and STOPBITS.")

    (tty.init speed bits parity stopbits 'none)
    (let ((out (openstream '{tty} 'output)))
         (prin1 (concat "0123 ABC abc " (packc '(1 2 3 255)))
                out)
         (closef out))))

(tty.menu
  (lambda nil                                                (* \; "Edited 19-Feb-87 22:57 by jds")
    (let ((ww (addmenu (|create| menu
                              menucolumns _ 4
                              items _ rs232.test.menu.items
                              whenselectedfn _ (function ttytmenu.selfn)))))
         (windowprop ww 'title "TTY Tests"))))

(ttytmenu.selfn
  (lambda (item menu key)                                    (* \; "Edited 19-Feb-87 22:59 by jds")
          
          (* |;;| "Called from the RS-232 test menu")

    (let* ((info (cadr item))
           (bits (car info))
           (parity (cadr info))
           (stopbits (caddr info)))
          (tty.quicktest 9600 bits parity stopbits))))
)
(PUTPROPS RS232TEST COPYRIGHT ("Venue & Xerox Corporation" 1987 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (979 2623 (RSTEST 989 . 1466) (TESTCLEANUP 1468 . 1789) (XMITTEST 1791 . 2621)) (2732 
5433 (RS232.TEST 2742 . 3570) (RS232.MICROTEST 3572 . 4151) (RS232.QUICKTEST 4153 . 4640) (RS232.MENU 
4642 . 5042) (RS232TMENU.SELFN 5044 . 5431)) (6665 9325 (TTY.TEST 6675 . 7493) (TTY.MICROTEST 7495 . 
8061) (TTY.QUICKTEST 8063 . 8543) (TTY.MENU 8545 . 8938) (TTYTMENU.SELFN 8940 . 9323)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/SKETCHCOLOR b/internal/library/OBSOLETE/SKETCHCOLOR
new file mode 100644
index 00000000..b0c99a51
--- /dev/null
+++ b/internal/library/OBSOLETE/SKETCHCOLOR
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "26-Jun-90 19:20:18" {DSK}<usr>local>lde>lispcore>internal>library>SKETCHCOLOR.;2 4982   

      changes to%:  (VARS SKETCHCOLORCOMS)

      previous date%: " 9-Jan-87 16:47:16" 
{DSK}<usr>local>lde>lispcore>internal>library>SKETCHCOLOR.;1)


(* ; "
Copyright (c) 1985, 1987, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT SKETCHCOLORCOMS)

(RPAQQ SKETCHCOLORCOMS ((FNS COLORTEXTURETEST LEVELTEXTURE PRIMARYTEXTURE)
                            (VARS (SKETCHINCOLORFLG T))
                            (FILES COLOR STYLESHEET)
                            (ADVISE \FILLCIRCLE.DISPLAY \POLYSHADE.DISPLAY)))
(DEFINEQ

(COLORTEXTURETEST
  [LAMBDA (W)                                                (* rrb "22-Aug-85 10:16")
                                                             (* puts up a test pattern of primary 
                                                             colors.)
    (PROG ((LFT 90))
          (CLEARW W)
          (for BLUELEVEL from 94 by 50 to 300
             do (printout W "BLUE: " BLUELEVEL "        " 'RED)
                (DSPYPOSITION (DIFFERENCE (DSPYPOSITION NIL W)
                                     50)
                       W)
                (DSPXPOSITION 0 W)
                (for GREENLEVEL from 94 by 50 to 300
                   do (printout W "Green: " GREENLEVEL)
                      [for REDLEVEL from 94 by 50 to 300
                         do (BITBLT NIL 0 0 W (DIFFERENCE REDLEVEL 20)
                                   (DSPYPOSITION NIL W)
                                   45 45 'TEXTURE 'REPLACE (TEXTUREOFCOLOR (LIST REDLEVEL GREENLEVEL 
                                                                                 BLUELEVEL]
                      (DSPYPOSITION (DIFFERENCE (DSPYPOSITION NIL W)
                                           50)
                             W)
                      (DSPXPOSITION 0 W])

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

(PRIMARYTEXTURE
  [LAMBDA (PRIMARY LEVEL)                                    (* rrb "20-Aug-85 16:42")
                                                             (* 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])
)

(RPAQQ SKETCHINCOLORFLG T)

(FILESLOAD COLOR STYLESHEET)

[XCL:REINSTALL-ADVICE '\FILLCIRCLE.DISPLAY :BEFORE '((:LAST (COND
                                                               ((LISTP TEXTURE)
                                                                (COND
                                                                   ((TEXTUREP (CAR TEXTURE))
                                                                    (SETQ TEXTURE (CAR TEXTURE)))
                                                                   (T (SETQ TEXTURE
                                                                       (TEXTUREOFCOLOR (CADR TEXTURE]

[XCL:REINSTALL-ADVICE '\POLYSHADE.DISPLAY :BEFORE '((:LAST (COND
                                                              ((LISTP FILL.SHADE)
                                                               (COND
                                                                  ((TEXTUREP (CAR FILL.SHADE))
                                                                   (SETQ FILL.SHADE (CAR FILL.SHADE))
                                                                   )
                                                                  (T (SETQ FILL.SHADE
                                                                      (TEXTUREOFCOLOR (CADR 
                                                                                           FILL.SHADE
                                                                                            ]

(READVISE \FILLCIRCLE.DISPLAY \POLYSHADE.DISPLAY)
(PUTPROPS SKETCHCOLOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (719 3316 (COLORTEXTURETEST 729 . 2076) (LEVELTEXTURE 2078 . 2610) (PRIMARYTEXTURE 2612
 . 3314)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/SOURCELOOKUP b/internal/library/OBSOLETE/SOURCELOOKUP
new file mode 100644
index 00000000..80c7e453
--- /dev/null
+++ b/internal/library/OBSOLETE/SOURCELOOKUP
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO �READTABLE "INTERLISP" �PACKAGE "INTERLISP")
(FILECREATED "26-Mar-87 09:52:19" {ERIS}<LISPCORE>LIBRARY>INTERNAL>SOURCELOOKUP.;1 5861   

      previous date%: "21-Jan-86 09:49:57" {ERIS}<JAMES>KOTO>SOURCELOOKUP.;2)


(* "
Copyright (c) 1985, 1986, 1987 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT SOURCELOOKUPCOMS)

(RPAQQ SOURCELOOKUPCOMS ((VARS KotoSourceIndex)
                         (FNS LOCATE.FUNCTION LOCATE.FILE)
                         (FILES WHEREIS)))

(RPAQQ KotoSourceIndex 
       ((|KOTO SOURCES #1| 10MBDRIVER 4045STREAM AARITH ABASIC ACODE ADDARITH ADIR ADVISE AERROR 
               AFONT AINTERRUPT AOFD)
        (|KOTO SOURCES #2| ADISPLAY APRINT APUTDQ ASSIST ASTACK BIG BITMAPFNS BRKDWN BUSEXTENDER)
        (|KOTO SOURCES #3| ATERM ATTACHEDWINDOW BREAK BROWSER BSP CENTRONICS)
        (|KOTO SOURCES #4| ATBL BUSMASTER BYTECOMPILER CHAT CIRCLPRINT)
        (|KOTO SOURCES #5| C150STREAM CHATTERMINAL CHECKSET CLISP CLISPIFY CML CMLARITH CMLFLOATARRAY 
               CMLSETF)
        (|KOTO SOURCES #6| CMLARRAY CMLARRAYINSPECTOR CMLCHARACTER CMLCOMPILE CMLEXEC CMLHELP 
               CMLPRETTY CMLPRINT CMLSPECIALFORMS CMLSTREAMS CMLSTRUCT CMLTYPES COLOR COLORDEMO 
               COMPATIBILITY)
        (|KOTO SOURCES #7| COMMENT COMMON COMPILE COMPILEBANG COPYFILES COREIO COURIER DATABASEFNS 
               DEDIT DEXEC)
        (|KOTO SOURCES #8| DECL DES DFILE DINFO DISKDLION DLAP)
        (|KOTO SOURCES #9| DLFIXINIT DLRS232C DLTTY DMCHAT DMISC DORADOCOLOR DOVEDECLS DOVEDISK 
               DOVEDISPLAY DOVEDISPLAYHACK DSKDISPLAY)
        (|KOTO SOURCES #10| DPUPFTP DWIMIFY EDITBITMAP)
        (|KOTO SOURCES #11| DOVEETHER DOVEFLOPPY DOVEINPUTOUTPUT EDIT FILECACHE HLCOLOR)
        (|KOTO SOURCES #12| DOVEMISC DSPRINTDEF DTDECLARE DWIM ETHERRECORDS FILEBROWSER FILEIO 
               FILESETS)
        (|KOTO SOURCES #13| FLOPPY)
        (|KOTO SOURCES #14| FASTFX80STREAM FILEPKG FONT FONTSAMPLE ICONW)
        (|KOTO SOURCES #15| FREEMENU FX80STREAM GCHAX GRAPHER)
        (|KOTO SOURCES #16| FTPSERVER FXPRINTER GRAPHZOOM HARDCOPY HASH HIST HPRINT)
        (|KOTO SOURCES #17| HELPDL HELPSYS HLDISPLAY HRULE IDLER IMAGEIO IMAGEOBJ INSPECT)
        (|KOTO SOURCES #18| INTERPRESS IOCHAR IRISCONSTANTS IRISIO IRISNET IRISSTREAM LAMBDATRAN)
        (|KOTO SOURCES #19| IRISLIB KERMIT KERMITMENU KEYBOARDEDITOR LABEL LISTEN LLARITH LLSUBRS)
        (|KOTO SOURCES #20| LEAF LLARRAYELT LLBFS LLCODE)
        (|KOTO SOURCES #21| LLBASIC LLBIGNUM LLCHAR LLCOLOR LLDATATYPE LLFCOMPILE MACROAUX)
        (|KOTO SOURCES #22| LLDISPLAY LLETHER LLFLOAT LOADIRIS)
        (|KOTO SOURCES #23| LLFAULT LLGC LLINTERP LLKEY)
        (|KOTO SOURCES #24| LLHUNK LLNEW LLNS LLNSDECLS LLPARAMS LLREAD LLSTK LLTIMER LOADFNS MEM 
               POSTLOADUP)
        (|KOTO SOURCES #25| LOCALFILE MACHINEINDEPENDENT MACROS PUPCHAT)
        (|KOTO SOURCES #26| MAKEINIT MASTERSCOPE MATCH MATMULT MENU MISC)
        (|KOTO SOURCES #27| MINISERVE MOD44IO MSANALYZE NEWPRINTDEF PCALLSTATS PRETTY)
        (|KOTO SOURCES #28| NSCHAT PRESS PROC PUP)
        (|KOTO SOURCES #29| MODARITH MSPARSE NSPRINT PASSWORDS PMAP PUPPRINT RDSYS READAIS READNUMBER 
               READSYS REMOTEVMEM RENAMEMACROS TEDITABBREV)
        (|KOTO SOURCES #30| RECORD RENAMEFNS RESOURCE RS232CHAT RS232CMENU SAMEDIR 
               SCAVENGEDSKDIRECTORY SFFONT SIMPLIFY SKETCHEDIT SKETCHOBJ TEDITCHAT)
        (|KOTO SOURCES #31| SKETCHELEMENTS SPELL)
        (|KOTO SOURCES #32| SKETCHSTREAM SPLICE SPP SPY SYSEDIT TABLEBROWSER TEDIT TEDITHISTORY)
        (|KOTO SOURCES #33| TEDITFILE TEDITLOOKS TEDITPAGE VMEM)
        (|KOTO SOURCES #34| TEDITMENU TEDITWINDOW VT100KP)
        (|KOTO SOURCES #35| TEDITCOMMAND TEDITFIND TEDITFNKEYS TEDITHCPY TEDITSCREEN TEK4010CHAT 
               XXGEOM)
        (|KOTO SOURCES #36| TEDITSELECTION TELERAID TEXEC TEXTOFD TFBRAVO)
        (|KOTO SOURCES #37| TRSERVER TTYCHAT TTYIN UNDO VANILLADISK WTFIX)
        (|KOTO SOURCES #38| VIRTUALKEYBOARDS WBREAK WINDOW XXFILL)
        (|KOTO SOURCES #39| SKETCH)
        (|KOTO SOURCES #40| SKETCH VTCHAT WEDIT WHEREIS)))
(DEFINEQ

(LOCATE.FUNCTION
  [LAMBDA (FUNC QUIETFLG)                                    (* ckj "21-Jan-86 09:49")
          
          (* * finds which Koto source file and floppy FUNC is defined on)
          
          (* * KotoSourceIndex is a list where each element is a list whose car is a 
          floppy name and cdr is the floppy contents)

    (PROG (WhichFile? WhichFloppy?)
          (SETQ WhichFile? (CAR (WHEREIS FUNC NIL T)))
          (if WhichFile?
              then (SETQ WhichFloppy? (LOCATE.FILE WhichFile? KotoSourceIndex))
            else (if (NOT QUIETFLG)
                     then (printout T .FONT BOLDFONT FUNC .FONT DEFAULTFONT " not found." T))
                 (RETURN))
          (if (NOT QUIETFLG)
              then (printout T "The function " .FONT BOLDFONT FUNC .FONT DEFAULTFONT 
                          " is defined in the file " .FONT BOLDFONT WhichFile? .FONT DEFAULTFONT 
                          " located on floppy " .FONT BOLDFONT WhichFloppy? .FONT DEFAULTFONT "." T))
          (RETURN (LIST WhichFile? WhichFloppy?])

(LOCATE.FILE
  [LAMBDA (FILENAME FLOPPYINDEX)                             (* DERING " 8-Jan-85 14:05")
          
          (* * FLOPPYINDEX IS A LIST WHERE EACH ELEMENT IS A LIST WHOSE CAR IS THE FLOPPY 
          NAME AND CDR IS THE FILES RESIDING ON THE FLOPPY.)

    (COND
       ((NULL (CAR FLOPPYINDEX))
        NIL)
       ((EQMEMB FILENAME (CAR FLOPPYINDEX))
        (CAAR FLOPPYINDEX))
       (T (LOCATE.FILE FILENAME (CDR FLOPPYINDEX])
)
(FILESLOAD WHEREIS)
(PUTPROPS SOURCELOOKUP COPYRIGHT ("Xerox Corporation" 1985 1986 1987))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (4149 5747 (LOCATE.FUNCTION 4159 . 5274) (LOCATE.FILE 5276 . 5745)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/SOURCELOOKUP.TEDIT b/internal/library/OBSOLETE/SOURCELOOKUP.TEDIT
new file mode 100644
index 00000000..7b6764e5
Binary files /dev/null and b/internal/library/OBSOLETE/SOURCELOOKUP.TEDIT differ
diff --git a/internal/library/OBSOLETE/STACKHACK b/internal/library/OBSOLETE/STACKHACK
new file mode 100644
index 00000000..5aa1385d
--- /dev/null
+++ b/internal/library/OBSOLETE/STACKHACK
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "26-Jun-90 19:26:19" |{DSK}<usr>local>lde>lispcore>internal>library>STACKHACK.;2| 2119   

      |changes| |to:|  (VARS STACKHACKCOMS)

      |previous| |date:| "11-May-88 11:28:17" 
|{DSK}<usr>local>lde>lispcore>internal>library>STACKHACK.;1|)


; Copyright (c) 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT STACKHACKCOMS)

(RPAQQ STACKHACKCOMS ((FNS DO-SKIP-FRAMES SKIP-FRAMES FRAGMENT-STACK)
                          (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
                                 (ADDVARS (NLAMA)
                                        (NLAML)
                                        (LAMA DO-SKIP-FRAMES)))))
(DEFINEQ

(do-skip-frames
(lambda i (* \; "Edited  7-Mar-88 15:35 by ") (envapply (quote skip-frames) (list (arg i 1) (arg i 2)) (quote skip-frames) (quote skip-frames)))
)

(skip-frames
  (lambda (n fn)                                     (* \; "Edited 11-May-88 11:19 by MASINTER")
                                                             (* \; 
                                                  "create some stack with N holes and then call FN")
    (|if| (zerop n)
        |then| (cl:funcall fn)
      |else| (cl:macrolet ((longcall (fn &rest args)
                                      `(apply ',fn (list* ,@args ',(|to| 500 |collect| nil)))
                                      ))
                        (longcall do-skip-frames (sub1 n)
                               fn)))))

(fragment-stack
  (lambda nil                                        (* \; "Edited 11-May-88 11:27 by MASINTER")
    (add.process '(do (skip-frames 10 (function (lambda nil
                                                          (dismiss 5000))))))))
)
(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA DO-SKIP-FRAMES)
)
(PUTPROPS STACKHACK COPYRIGHT ("Venue & Xerox Corporation" 1988 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (770 1878 (DO-SKIP-FRAMES 780 . 946) (SKIP-FRAMES 948 . 1602) (FRAGMENT-STACK 1604 . 
1876)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/TEDITCOLOR b/internal/library/OBSOLETE/TEDITCOLOR
new file mode 100644
index 00000000..92654b13
--- /dev/null
+++ b/internal/library/OBSOLETE/TEDITCOLOR
@@ -0,0 +1 @@
+(FILECREATED "26-Feb-86 10:59:11" {ERIS}<LISPCORE>LIBRARY>TEDITCOLOR.;3 26648  

      changes to:  (VARS TEDITCOLORCOMS)

      previous date: "26-Feb-86 10:44:36" {ERIS}<LISPCORE>LIBRARY>TEDITCOLOR.;1)


(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT TEDITCOLORCOMS)

(RPAQQ TEDITCOLORCOMS ((* * These function definitions should be added to IMAGEOBJ, TEDITSCREEN, 
                              and TEDITWINDOW. They have been tested to the point of creating, 
                              putting, and getting color TEDIT files. \TEDIT.SLOWBLTCHAR is a new 
                              function. *)
                           (* * NOTE: The MACRO property for SCREENBITMAP was eliminated 25-FEB. 
                              Either LOAD the new EXPORTS.ALL or just (REMPROP (QUOTE SCREENBITMAP)
                                                                             (QUOTE MACRO))
                              so that the IMAGEOBJ functions will compile correctly. *)
                           (COMS (* * Modifications to IMAGEOBJ. *)
                                 (FNS BITMAPOBJ.SNAPW COERCETOBITMAP))
                           (COMS (* * Modifications to TEDITSCREEN. (\TEDIT.SLOWBLTCHAR is a new 
                                                                           function.)
                                    *)
                                 (FNS \TEDIT.BLTCHAR \TEDIT.SLOWBLTCHAR \TEDIT.CREATE.LINECACHE 
                                      \TEDIT.LINECACHE))
                           (COMS (* * Modifications to TEDITWINDOW. *)
                                 (FNS TEDIT.MINIMAL.WINDOW.SETUP))))
(* * These function definitions should be added to IMAGEOBJ, TEDITSCREEN, and TEDITWINDOW. 
They have been tested to the point of creating, putting, and getting color TEDIT files. 
\TEDIT.SLOWBLTCHAR is a new function. *)

(* * NOTE: The MACRO property for SCREENBITMAP was eliminated 25-FEB. Either LOAD the new 
EXPORTS.ALL or just (REMPROP (QUOTE SCREENBITMAP) (QUOTE MACRO)) so that the IMAGEOBJ functions
 will compile correctly. *)

(* * Modifications to IMAGEOBJ. *)

(DEFINEQ

(BITMAPOBJ.SNAPW
  (LAMBDA NIL                                                         (* kbr: 
                                                                          "25-Feb-86 17:06")
            
            (* * makes an image object of a prompted for region of the screen.)

    (PROG (SCREENREGION SCREEN REGION BM)
          (SETQ SCREENREGION (GETSCREENREGION))
          (SETQ SCREEN (fetch (SCREENREGION SCREEN) of SCREENREGION))
          (SETQ REGION (fetch (SCREENREGION REGION) of SCREENREGION))
          (SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REGION)
                          (fetch (REGION HEIGHT) of REGION)
                          (BITSPERPIXEL (SCREENBITMAP SCREEN))))
          (BITBLT (SCREENBITMAP SCREEN)
                 (fetch (REGION LEFT) of REGION)
                 (fetch (REGION BOTTOM) of REGION)
                 BM 0 0 NIL NIL (QUOTE INPUT)
                 (QUOTE REPLACE))
          (COPYINSERT (BITMAPTEDITOBJ BM 1 0)))))

(COERCETOBITMAP
  (LAMBDA (BMSPEC)                                                    (* kbr: 
                                                                          "25-Feb-86 17:09")
                                                                          (* tries to interpret 
                                                                          X as a spec for a 
                                                                          bitmap.)
    (PROG (BM CR)
          (RETURN (COND
                     ((BITMAPP BMSPEC)
                      BMSPEC)
                     ((LITATOM BMSPEC)                                    (* use value.)
                      (COND
                         ((BITMAPP (EVALV BMSPEC (QUOTE COERCETOBITMAP))))))
                     ((REGIONP BMSPEC)                                    (* if BMSPEC is a 
                                                                          region, treat it as a 
                                                                          region of the screen.)
                      (SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of BMSPEC)
                                      (fetch (REGION HEIGHT) of BMSPEC)
                                      (BITSPERPIXEL (SCREENBITMAP))))
                      (BITBLT (SCREENBITMAP)
                             (fetch (REGION LEFT) of BMSPEC)
                             (fetch (REGION BOTTOM) of BMSPEC)
                             BM 0 0 NIL NIL (QUOTE INPUT)
                             (QUOTE REPLACE))
                      BM)
                     ((type? SCREENREGION BMSPEC)                     (* if BMSPEC is a 
                                                                          screenregion)
                      (SETQ BM (BITMAPCREATE (fetch (SCREENREGION WIDTH) of BMSPEC)
                                      (fetch (SCREENREGION HEIGHT) of BMSPEC)
                                      (BITSPERPIXEL (SCREENBITMAP (fetch (SCREENREGION SCREEN)
                                                                     of BMSPEC)))))
                      (BITBLT (SCREENBITMAP (fetch (SCREENREGION SCREEN) of BMSPEC))
                             (fetch (SCREENREGION LEFT) of BMSPEC)
                             (fetch (SCREENREGION BOTTOM) of BMSPEC)
                             BM 0 0 NIL NIL (QUOTE INPUT)
                             (QUOTE REPLACE))
                      BM)
                     ((WINDOWP BMSPEC)
                      (SETQ BM (BITMAPCREATE (WINDOWPROP BMSPEC (QUOTE WIDTH))
                                      (WINDOWPROP BMSPEC (QUOTE HEIGHT))
                                      (BITSPERPIXEL BMSPEC)))             (* open the window and 
                                                                          bring it to the top.)
                      (TOTOPW BMSPEC)
                      (SETQ CR (DSPCLIPPINGREGION NIL BMSPEC))
                      (BITBLT BMSPEC (fetch LEFT of CR)
                             (fetch BOTTOM of CR)
                             BM 0 0 (fetch WIDTH of CR)
                             (fetch HEIGHT of CR))
                      BM))))))
)
(* * Modifications to TEDITSCREEN. (\TEDIT.SLOWBLTCHAR is a new function.) *)

(DEFINEQ

(\TEDIT.BLTCHAR
  (LAMBDA (CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT CLIPRIGHT)
                                                                          (* kbr: 
                                                                          "25-Feb-86 22:40")
                                                                          (* Version of \BLTCHAR 
                                                                          peculiar to TEdit --
                                                                          relies on \DISPLAYLINE 
                                                                          to make sure things keep 
                                                                          working right.)
            
            (* puts a character on a guaranteed display stream.
            Much of the information needed by the BitBlt microcode is prestored by the 
            routines that change it. This is kept in the BitBltTable.)
                                                                          (* knows about the 
                                                                          representation of 
                                                                          display stream image 
                                                                          data)
                                                                          (* MUST NOT POINT AT A 
                                                                          WINDOW'S 
                                                                          DISPLAYSTREAM!!!)
            
            (* ASSUMES THAT WE NEVER WANT TO PRINT TO THE LEFT OF ORIGIN 0 ON THE 
            LINE CACHE BITMAP, OR THAT IF WE DO, ALL BETS ARE OFF)

    (DECLARE (LOCALVARS . T))
    (PROG (CHAR8CODE NEWX LEFT RIGHT IMAGEWIDTH)
          (SETQ CHAR8CODE (\CHAR8CODE CHARCODE))
          (COND
             ((NOT (EQ (ffetch (\DISPLAYDATA DDCHARSET) of DISPLAYDATA)
                       (\CHARSET CHARCODE)))
              (\CHANGECHARSET.DISPLAY DISPLAYDATA (\CHARSET CHARCODE))))
          (COND
             ((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA)
              (RETURN (\TEDIT.SLOWBLTCHAR CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT 
                             CLIPRIGHT))))
          (SETQ IMAGEWIDTH (\GETBASE (fetch (\DISPLAYDATA DDCHARIMAGEWIDTHS) of DISPLAYDATA)
                                  (\CHAR8CODE CHARCODE)))
          (SETQ NEWX (IPLUS CURX IMAGEWIDTH))
          (SETQ LEFT (IMAX 0 CURX))
          (SETQ RIGHT (IMIN CLIPRIGHT NEWX))
          (COND
             ((ILESSP LEFT RIGHT)                                         (* Only print anything 
                                                                          if there is a place to 
                                                                          put it)
              (UNINTERRUPTABLY
                  (freplace (PILOTBBT PBTDESTBIT) of DDPILOTBBT with LEFT)
                                                                           (* Set up the 
                                                                           bitblt-table source 
                                                                           left)
                  (freplace (PILOTBBT PBTWIDTH) of DDPILOTBBT with (IMIN IMAGEWIDTH
                                                                                     (IDIFFERENCE
                                                                                      RIGHT LEFT)))
                  (freplace (PILOTBBT PBTSOURCEBIT) of DDPILOTBBT
                     with (\GETBASE (fetch (\DISPLAYDATA DDOFFSETSCACHE) of DISPLAYDATA)
                                     (\CHAR8CODE CHARCODE)))
                  (\PILOTBITBLT DDPILOTBBT 0))
              (RETURN T))))))

(\TEDIT.SLOWBLTCHAR
  (LAMBDA (CHARCODE DISPLAYSTREAM CURX DISPLAYDATA DDPILOTBBT CLIPRIGHT)
                                                                          (* kbr: 
                                                                          "25-Feb-86 22:40")
                                                                          (* Version of 
                                                                          \SLOWBLTCHAR peculiar to 
                                                                          TEdit -- relies on 
                                                                          \DISPLAYLINE to make 
                                                                          sure things keep working 
                                                                          right. Does not handle 
                                                                          rotated fonts.)
    (PROG (CHAR8CODE NEWX LEFT RIGHT IMAGEWIDTH DESTBIT WIDTH SOURCEBIT)
          (SETQ CHAR8CODE (\CHAR8CODE CHARCODE))
          (SETQ IMAGEWIDTH (\GETBASE (fetch (\DISPLAYDATA DDCHARIMAGEWIDTHS) of DISPLAYDATA)
                                  (\CHAR8CODE CHARCODE)))
          (SETQ NEWX (IPLUS CURX IMAGEWIDTH))
          (SETQ LEFT (IMAX 0 CURX))
          (SETQ RIGHT (IMIN CLIPRIGHT NEWX))
          (COND
             ((ILESSP LEFT RIGHT)
              (SETQ DESTBIT LEFT)
              (SETQ WIDTH (IDIFFERENCE RIGHT LEFT))
              (SETQ SOURCEBIT (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHAR8CODE DISPLAYDATA)
                                                  LEFT)
                                     CURX))
              (SELECTQ (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch (\DISPLAYDATA
                                                                                   DDDestination)
                                                                         of DISPLAYDATA))
                  (1)
                  (4 (SETQ DESTBIT (LLSH DESTBIT 2))
                     (SETQ WIDTH (LLSH WIDTH 2))
                     (SETQ SOURCEBIT (LLSH SOURCEBIT 2)))
                  (8 (SETQ DESTBIT (LLSH DESTBIT 3))
                     (SETQ WIDTH (LLSH WIDTH 3))
                     (SETQ SOURCEBIT (LLSH SOURCEBIT 3)))
                  (24 (SETQ DESTBIT (ITIMES 24 DESTBIT))
                      (SETQ WIDTH (ITIMES 24 WIDTH))
                      (SETQ SOURCEBIT (ITIMES 24 SOURCEBIT)))
                  (SHOULDNT))
              (.WHILE.TOP.DS. DISPLAYSTREAM (freplace (PILOTBBT PBTDESTBIT) of DDPILOTBBT
                                               with DESTBIT)
                     (freplace (PILOTBBT PBTWIDTH) of DDPILOTBBT with WIDTH)
                     (freplace (PILOTBBT PBTSOURCEBIT) of DDPILOTBBT with SOURCEBIT)
                     (\PILOTBITBLT DDPILOTBBT 0))
              (RETURN T))))))

(\TEDIT.CREATE.LINECACHE
  (LAMBDA (#CACHES BITSPERPIXEL)                                      (* kbr: 
                                                                          "25-Feb-86 18:47")
                                                                          (* Create a 
                                                                          linked-together set of 
                                                                          LINECACHEs, for saving 
                                                                          line images.)
    (PROG ((CACHES (for I from 1 to #CACHES collect (create LINECACHE
                                                                           LCBITMAP _(BITMAPCREATE
                                                                                      100 15 
                                                                                      BITSPERPIXEL)))
                  ))
          (for CACHE on CACHES do                             (* Link the caches 
                                                                          together.)
                                             (replace LCNEXTCACHE of (CAR CACHE)
                                                with (OR (CADR CACHE)
                                                             (CAR CACHES))))
          (RETURN CACHES))))

(\TEDIT.LINECACHE
  (LAMBDA (CACHE WIDTH HEIGHT)                                        (* kbr: 
                                                                          "25-Feb-86 18:48")
                                                                          (* Given a candidate 
                                                                          line cache, return the 
                                                                          bitmap, making sure it's 
                                                                          at least WIDTH by HEIGHT 
                                                                          big.)
    (PROG ((BITMAP (fetch LCBITMAP of CACHE))
           CW CH)
          (SETQ CW (fetch BITMAPWIDTH of BITMAP))
          (SETQ CH (fetch BITMAPHEIGHT of BITMAP))
          (COND
             ((AND (IGEQ CW WIDTH)
                   (IGEQ CH HEIGHT))
              (RETURN BITMAP))
             (T (RETURN (replace LCBITMAP of CACHE with (BITMAPCREATE (IMAX CW WIDTH)
                                                                           (IMAX CH HEIGHT)
                                                                           (BITSPERPIXEL BITMAP))))))
     )))
)
(* * Modifications to TEDITWINDOW. *)

(DEFINEQ

(TEDIT.MINIMAL.WINDOW.SETUP
  (LAMBDA (WINDOW TEXTOBJ TEXTSTREAM PROPS AFTERWINDOW)               (* kbr: 
                                                                          "25-Feb-86 18:46")
                                                                          (* Do the absolute 
                                                                          minimum setup so that 
                                                                          TEXTOBJ and WINDOW know 
                                                                          about each other.
                                                                          Does NOT include mouse 
                                                                          interface or scrolling.)
            
            (* If AFTERWINDOW is non-NIL, the new window will be placed after 
            AFTERWINDOW in the TEXTOBJ's list. This lists us maintain an ordering of 
            windows, for splitting and unsplitting.)

    (PROG ((SEL (fetch SEL of TEXTOBJ))
           TEDITPROMPTWINDOW DS PROP TWIDTH THEIGHT LINES OLDWINDOWS)
          (OR WINDOW (\ILLEGAL.ARG WINDOW))
          (replace (TEDITCARET TCCARETDS) of (COND
                                                        ((LISTP (fetch CARET of TEXTOBJ))
                                                         (CAR (FLAST (fetch CARET of TEXTOBJ)
                                                                     )))
                                                        (T (fetch CARET of TEXTOBJ)))
             with (WINDOWPROP WINDOW (QUOTE DSP)))                    (* The displaystream 
                                                                          for flashing the caret)
          (replace SELWINDOW of TEXTOBJ with WINDOW)
          (WINDOWPROP WINDOW (QUOTE PROCESS)
                 NIL)                                                     (* For the moment, 
                                                                          this window has no 
                                                                          process)
          (WINDOWPROP WINDOW (QUOTE TEDIT.PROPS)
                 PROPS)                                                   (* Put the props on 
                                                                          the window for others 
                                                                          ... **this should go**)
          (WINDOWPROP WINDOW (QUOTE TEXTSTREAM)
                 TEXTSTREAM)                                              (* Save the text 
                                                                          stream for the user to 
                                                                          get at via the window.)
          (WINDOWPROP WINDOW (QUOTE TEXTOBJ)
                 TEXTOBJ)                                                 (* Give a handle on 
                                                                          the TEXTOBJ for the text 
                                                                          being edited.)
          (WINDOWPROP WINDOW (QUOTE TEDIT.CURSORREGION)
                 (LIST 0 0 0 0))                                          (* Used by 
                                                                          CursorMovedFn)
          (WINDOWPROP WINDOW (QUOTE CURSORMOVEDFN)
                 (FUNCTION TEDIT.CURSORMOVEDFN))
          (WINDOWPROP WINDOW (QUOTE CURSOROUTFN)
                 (FUNCTION TEDIT.CURSOROUTFN))
          (SETQ DS (WINDOWPROP WINDOW (QUOTE DSP)))
          (DSPRIGHTMARGIN 32767 DS)                                       (* So we don't get 
                                                                          spurious RETURNs printed 
                                                                          out by the system)
          (SETQ OLDWINDOWS (fetch \WINDOW of TEXTOBJ))
          (replace \WINDOW of TEXTOBJ
             with (COND
                         ((LISTP OLDWINDOWS)                              (* There are windows 
                                                                          already. Add this to the 
                                                                          list.)
                          (COND
                             (AFTERWINDOW                                 (* We know which 
                                                                          window to put it after.
                                                                          Put it there)
                                    (RPLACD (FMEMB AFTERWINDOW OLDWINDOWS)
                                           (CONS WINDOW (CDR (FMEMB AFTERWINDOW OLDWINDOWS)))))
                             (T                                           (* Otherwise, just add 
                                                                          it at the end of the 
                                                                          list)
                                (NCONC1 OLDWINDOWS WINDOW))))
                         (WINDOW (LIST WINDOW))))
          (replace DISPLAYCACHE of TEXTOBJ with (CAR (\TEDIT.CREATE.LINECACHE
                                                                  1
                                                                  (BITSPERPIXEL WINDOW))))
                                                                          (* and a CACHE for 
                                                                          creating line images for 
                                                                          display)
          (replace DISPLAYCACHEDS of TEXTOBJ with (DSPCREATE (fetch LCBITMAP
                                                                            of (fetch 
                                                                                         DISPLAYCACHE
                                                                                      of TEXTOBJ)
                                                                                )))
                                                                          (* A displaystream for 
                                                                          changeing the image 
                                                                          caches)
          (DSPOPERATION (QUOTE PAINT)
                 (fetch DISPLAYCACHEDS of TEXTOBJ))
          (DSPCLIPPINGREGION (create REGION
                                    LEFT _ 0
                                    BOTTOM _ 0
                                    WIDTH _ 100
                                    HEIGHT _ 15)
                 (fetch DISPLAYCACHEDS of TEXTOBJ))               (* Remember its size, 
                                                                          too.)
          (COND
             ((SETQ PROP (LISTGET PROPS (QUOTE REGION)))                  (* The caller wants to 
                                                                          set a region.
                                                                          Use his)
              (replace WTOP of TEXTOBJ with (fetch PTOP of PROP))
              (replace WRIGHT of TEXTOBJ with (fetch RIGHT of PROP))
              (replace WBOTTOM of TEXTOBJ with (fetch BOTTOM of PROP))
              (replace WLEFT of TEXTOBJ with (fetch LEFT of PROP)))
             (T                                                           (* Otherwise, default 
                                                                          to the whole window)
                (replace WLEFT of TEXTOBJ with 0)
                (replace WBOTTOM of TEXTOBJ with 0)
                (replace WTOP of TEXTOBJ with (fetch HEIGHT of (DSPCLIPPINGREGION
                                                                                    NIL DS)))
                (replace WRIGHT of TEXTOBJ with (fetch WIDTH of (
                                                                                    DSPCLIPPINGREGION
                                                                                     NIL DS)))))
          (SETQ LINES (\SHOWTEXT TEXTOBJ NIL WINDOW))
          (WINDOWPROP WINDOW (QUOTE LINES)
                 LINES)                                                   (* Display the text in 
                                                                          the window, for later 
                                                                          use.)
          (replace LINES of TEXTOBJ with (COND
                                                        (AFTERWINDOW
                                                         (for LINE
                                                            in (fetch LINES of TEXTOBJ)
                                                            as WINDOW in OLDWINDOWS
                                                            join (COND
                                                                        ((EQ WINDOW AFTERWINDOW)
                                                                         (LIST LINE LINES))
                                                                        (T (LIST LINE)))))
                                                        ((LISTP (fetch LINES of TEXTOBJ))
                                                         (NCONC1 (fetch LINES of TEXTOBJ)
                                                                LINES))
                                                        (LINES (LIST LINES))))
          (\FIXSEL SEL TEXTOBJ)
          (TEDIT.NORMALIZECARET TEXTOBJ SEL)
          (\SHOWSEL SEL NIL T)
          (\TEDIT.SET.WINDOW.EXTENT TEXTOBJ WINDOW)
          (\COPYSEL SEL TEDIT.SELECTION))))
)
(PUTPROPS TEDITCOLOR COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2176 6545 (BITMAPOBJ.SNAPW 2186 . 3223) (COERCETOBITMAP 3225 . 6543)) (6630 16302 (
\TEDIT.BLTCHAR 6640 . 10617) (\TEDIT.SLOWBLTCHAR 10619 . 13567) (\TEDIT.CREATE.LINECACHE 13569 . 15010
) (\TEDIT.LINECACHE 15012 . 16300)) (16347 26567 (TEDIT.MINIMAL.WINDOW.SETUP 16357 . 26565)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/USPS b/internal/library/OBSOLETE/USPS
new file mode 100644
index 00000000..10aa4a42
--- /dev/null
+++ b/internal/library/OBSOLETE/USPS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "26-Jun-90 19:31:43" |{DSK}<usr>local>lde>lispcore>internal>library>USPS.;2| 9175   

      |changes| |to:|  (VARS USPSCOMS)

      |previous| |date:| "13-Feb-89 13:49:35" |{DSK}<usr>local>lde>lispcore>internal>library>USPS.;1|
)


; Copyright (c) 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT USPSCOMS)

(RPAQQ USPSCOMS
       (
        (* |;;| "Image Objects and functions for dealing with various kinds of mail.")

        (COMS 
              (* |;;| "FIMs -- \"Facing Identification Marks\" used with Business Reply Mail.  The top of a FIM must be within 1/8\" of the top of the envelope or card, and the right edge of the FIM must be 2\" +/- 1/8\" from the right edge of the card.  You can tilt the FIM no more than 5 degrees from vertical.")

              (FNS USPS-FIM.BUTTONEVENTINFN USPS-FIM.COPYFN USPS-FIM.CREATE USPS-FIM.CREATE.MENU 
                   USPS-FIM.DISPLAYFN USPS-FIM.GETFN3 USPS-FIM.IMAGEBOXFN USPS-FIM.INIT 
                   USPS-FIM.PUTFN)
              (GLOBALVARS USPS-FIM.IMAGEFNS USPS-FIM.MENU
                     (USPS-FIM.STYLES '((A T T NIL NIL T NIL NIL T T)
                                        (B T NIL T T NIL T T NIL T)
                                        (C T T NIL T NIL T NIL T T)
                                        (D T T T NIL T NIL T T T))))
              (P (USPS-FIM.INIT)))))



(* |;;| "Image Objects and functions for dealing with various kinds of mail.")




(* |;;| 
"FIMs -- \"Facing Identification Marks\" used with Business Reply Mail.  The top of a FIM must be within 1/8\" of the top of the envelope or card, and the right edge of the FIM must be 2\" +/- 1/8\" from the right edge of the card.  You can tilt the FIM no more than 5 degrees from vertical."
)

(DEFINEQ

(USPS-FIM.BUTTONEVENTINFN
  (LAMBDA (IMAGEOBJ WINDOW SELECTION X Y SELWINDOW TEXTSTREAM BUTTON OPERATION)
                                                             (* \; "Edited 13-Feb-89 12:29 by jds")

(* |;;;| "the user has pressed a button inside the bitmap object IMAGEOBJ.  Bring up a menu of bitmap edit operations.")

    (PROG* ((FIM-STYLE (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)))
           (COND
              ((OR (EQ BUTTON 'RIGHT)
                   (AND OPERATION (NEQ OPERATION 'NORMAL)))  (* \; " If he's extending a selection, or is selecting for move/copy/delete, DON'T bring up the bitmap editing menu!")
               (RETURN)))
           (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM (OR (MENU (COND
                                                            ((|type?| MENU USPS-FIM.MENU)
                                                             USPS-FIM.MENU)
                                                            (T (SETQ USPS-FIM.MENU (
                                                                               USPS-FIM.CREATE.MENU
                                                                                    )))))
                                                   FIM-STYLE))
           (IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP NIL)        (* \; 
                             "And clear any cached shrunk bitmaps so the display looks reasonable.")
           (RETURN 'CHANGED))))

(USPS-FIM.COPYFN
  (LAMBDA (IMAGEOBJ)                                     (* \; "Edited 13-Feb-89 13:03 by jds")

    (* |;;| "makes a copy of a bitmap image object.")

    (USPS-FIM.CREATE (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))))

(USPS-FIM.CREATE
  (LAMBDA (FIM-STYLE)                                    (* \; "Edited 13-Feb-89 12:00 by jds")

    (* |;;| "returns an IMAGEOBJ that displays/prints as a Postal Service Facing Identification Mark for business-reply mail.")

    (IMAGEOBJCREATE FIM-STYLE BITMAPIMAGEFNS)))

(USPS-FIM.CREATE.MENU
  (LAMBDA NIL                                            (* \; "Edited 13-Feb-89 12:27 by jds")

    (* |;;| "Creates the menu that comes up when you button in a FIM image object.")

    (|create| MENU
           TITLE _ "New Facing Style"
           ITEMS _ '(A B C D)
           CENTERFLG _ T
           CHANGEOFFSETFLG _ 'Y
           MENUOFFSET _ (|create| POSITION
                               XCOORD _ -1
                               YCOORD _ 0))))

(USPS-FIM.DISPLAYFN
  (LAMBDA (IMAGEOBJ IMAGE.STREAM)                        (* \; "Edited 13-Feb-89 12:18 by jds")

    (* |;;| "Display a bitmap IMAGEOBJ on IMAGE.STREAM.  Scales and rotates it if appropriate, and moves it down by DESCENT.")

    (LET* ((FIM-STYLE-LIST (CDR (ASSOC (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM)
                                       USPS-FIM.STYLES)))
           (STREAM-SCALE (DSPSCALE NIL IMAGE.STREAM))
           (LINE-PITCH (FIXR (FTIMES STREAM-SCALE 72.27 1/16)))
           (LINE-WIDTH (FIXR (FTIMES STREAM-SCALE 72.27 0.031)))
           (FIM-HEIGHT (FIXR (FTIMES STREAM-SCALE (CONSTANT (TIMES 72.27 5/8)))))
           SHRUNK.BITMAP)
          (RELMOVETO 0 (IMINUS FIM-HEIGHT)
                 IMAGE.STREAM)
          (|for| LINE-P |in| FIM-STYLE-LIST |do| (COND
                                                                (LINE-P (RELDRAWTO 0 FIM-HEIGHT 
                                                                               LINE-WIDTH
                                                                               'PAINT IMAGE.STREAM)
                                                                       (RELMOVETO LINE-PITCH
                                                                              (IMINUS FIM-HEIGHT)
                                                                              IMAGE.STREAM))
                                                                (T (RELMOVETO LINE-PITCH 0 
                                                                          IMAGE.STREAM)))))))

(USPS-FIM.GETFN3
  (LAMBDA (STREAM)                                       (* \; "Edited 13-Feb-89 13:49 by jds")

(* |;;;| "reads a bitmap image object from a file.  This version stores the binary data rather than the character representation used by READBITMAP.")

    (USPS-FIM.CREATE (SELECTQ (\\BIN STREAM)
                             (0 'A)
                             (1 'B)
                             (2 'C)
                             (3 'D)
                             (HELP "Illegal FIM style")))))

(USPS-FIM.IMAGEBOXFN
  (LAMBDA (IMAGEOBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* \; "Edited 13-Feb-89 12:19 by jds")

    (* |;;| "returns an imagebox describing the size of the scaled bitmap")

    (LET* ((FIM-STYLE (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))
           (SCALE (DSPSCALE NIL IMAGE.STREAM))
           WIDTH HEIGHT)
          (SETQ WIDTH (FIXR (FTIMES SCALE (CONSTANT (FTIMES 72.27 (+ 9/16 0.031))))))
          (SETQ HEIGHT (FIXR (FTIMES SCALE (CONSTANT (TIMES 72.27 5/8)))))
          (|create| IMAGEBOX
                 XSIZE _ WIDTH
                 YSIZE _ HEIGHT
                 YDESC _ HEIGHT
                 XKERN _ 0))))

(USPS-FIM.INIT
  (LAMBDA NIL                                            (* \; "Edited 13-Feb-89 12:02 by jds")

    (* |;;| 
  "returns the function vector which gives the functional information for a bitmap image object.")

    (SETQ BITMAPIMAGEFNS (IMAGEFNSCREATE (FUNCTION USPS-FIM.DISPLAYFN)
                                (FUNCTION USPS-FIM.IMAGEBOXFN)
                                (FUNCTION USPS-FIM.PUTFN)
                                (FUNCTION USPS-FIM.GETFN3)
                                (FUNCTION USPS-FIM.COPYFN)
                                (FUNCTION USPS-FIM.BUTTONEVENTINFN)
                                (FUNCTION NILL)
                                (FUNCTION NILL)
                                (FUNCTION NILL)
                                (FUNCTION NILL)
                                (FUNCTION NILL)
                                (FUNCTION NILL)
                                (FUNCTION NILL)))))

(USPS-FIM.PUTFN
  (LAMBDA (OBJECT STREAM)                                (* \; "Edited 13-Feb-89 12:05 by jds")
                                                             (* \; 
                                                 "Put a description of a FIM object into the file.")
    (LET* ((FIM-STYLE (IMAGEOBJPROP OBJECT 'OBJECTDATUM)))
          (\\BOUT STREAM (SELECTQ FIM-STYLE
                             (A 0)
                             (B 1)
                             (C 2)
                             (D 3)
                             (HELP "Invalid FIM Style" FIM-STYLE))))))
)
(DECLARE\: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS USPS-FIM.IMAGEFNS USPS-FIM.MENU
       (USPS-FIM.STYLES '((A T T NIL NIL T NIL NIL T T)
                          (B T NIL T T NIL T T NIL T)
                          (C T T NIL T NIL T NIL T T)
                          (D T T T NIL T NIL T T T))))
)

(USPS-FIM.INIT)
(PUTPROPS USPS COPYRIGHT ("Venue & Xerox Corporation" 1989 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (1863 8764 (USPS-FIM.BUTTONEVENTINFN 1873 . 3332) (USPS-FIM.COPYFN 3334 . 3583) (
USPS-FIM.CREATE 3585 . 3891) (USPS-FIM.CREATE.MENU 3893 . 4397) (USPS-FIM.DISPLAYFN 4399 . 5982) (
USPS-FIM.GETFN3 5984 . 6518) (USPS-FIM.IMAGEBOXFN 6520 . 7182) (USPS-FIM.INIT 7184 . 8146) (
USPS-FIM.PUTFN 8148 . 8762)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/color.brainstorming b/internal/library/OBSOLETE/color.brainstorming
new file mode 100644
index 00000000..5260280b
Binary files /dev/null and b/internal/library/OBSOLETE/color.brainstorming differ
diff --git a/internal/library/OBSOLETE/datepatch b/internal/library/OBSOLETE/datepatch
new file mode 100644
index 00000000..d6ffd287
--- /dev/null
+++ b/internal/library/OBSOLETE/datepatch
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jun-90 13:42:42" {DSK}<usr>local>lde>lispcore>internal>library>datepatch.;2 17784  

      changes to%:  (VARS DATEPATCHCOMS)

      previous date%: "30-May-89 12:29:12" {DSK}<usr>local>lde>lispcore>internal>library>datepatch.;1
)


(* ; "
Copyright (c) 1989, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT DATEPATCHCOMS)

(RPAQQ DATEPATCHCOMS
       (
        (* ;; "Patches to the date parser and printer:  IDATE parses many more dates now (full month names, more time zones).  GDATE handles timezones outside of US.")

        (FNS IDATE \IDATESCANTOKEN \IDATE-PARSE-MONTH \OUTDATE \OUTDATE-STRING \UNPACKDATE)
        (VARS TIME.ZONES)
        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS \4YearsDays)
               (LOCALVARS . T)
               (GLOBALVARS TIME.ZONES \TimeZoneComp \DayLightSavings)
               (SPECVARS *STR* *POS*))))



(* ;; 
"Patches to the date parser and printer:  IDATE parses many more dates now (full month names, more time zones).  GDATE handles timezones outside of US."
)

(DEFINEQ

(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 (CL: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)) (CL:MULTIPLE-VALUE-BIND (H M) (CL: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 (CL: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.") (CL: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 (CL:REMOVE (SETQ C (CAAAR FORMS)) FORMS :KEY (QUOTE CAAR))) (BQUOTE ((\, C) (SETQ CODEVAR (CDR CODEVAR)) (DISCRIMINATE-1 (\, (SUB1 MINCHARS)) (\,@ (FOR F IN (CL: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") (CL: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 (CL: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 (CL: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 (CL:MULTIPLE-VALUE-BIND (H M) (CL: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)))
)

(\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.") (CL:MULTIPLE-VALUE-SETQ (ZONE FRAC) (CL: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)") (CL:MULTIPLE-VALUE-SETQ (FRAC MIN) (CL:FLOOR (+ MIN FRAC) 60)) (if (NEQ FRAC 0) then (* ; "Adjust the hours") (CL:MULTIPLE-VALUE-SETQ (FRAC HR) (CL: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))))
)
)

(RPAQQ 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%: EVAL@COMPILE 

(RPAQQ \4YearsDays 1461)


(CONSTANTS \4YearsDays)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS TIME.ZONES \TimeZoneComp \DayLightSavings)
)

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(SPECVARS *STR* *POS*)
)
)
(PUTPROPS DATEPATCH COPYRIGHT ("Venue & Xerox Corporation" 1989 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1141 17140 (IDATE 1151 . 6017) (\IDATESCANTOKEN 6019 . 6745) (\IDATE-PARSE-MONTH 6747
 . 8757) (\OUTDATE 8759 . 13596) (\OUTDATE-STRING 13598 . 13980) (\UNPACKDATE 13982 . 17138)))))
STOP
\ No newline at end of file
diff --git a/internal/library/OBSOLETE/datepatch.tedit b/internal/library/OBSOLETE/datepatch.tedit
new file mode 100644
index 00000000..e5a565ed
Binary files /dev/null and b/internal/library/OBSOLETE/datepatch.tedit differ
diff --git a/internal/library/OBSOLETE/filebanger.tedit b/internal/library/OBSOLETE/filebanger.tedit
new file mode 100644
index 00000000..6d5132c1
Binary files /dev/null and b/internal/library/OBSOLETE/filebanger.tedit differ
diff --git a/internal/library/OBSOLETE/vpcdisk-setup.tedit b/internal/library/OBSOLETE/vpcdisk-setup.tedit
new file mode 100644
index 00000000..188f3c3f
Binary files /dev/null and b/internal/library/OBSOLETE/vpcdisk-setup.tedit differ
diff --git a/internal/library/PACKAGE-CODE.TEDIT b/internal/library/PACKAGE-CODE.TEDIT
new file mode 100644
index 00000000..0cf52ff3
Binary files /dev/null and b/internal/library/PACKAGE-CODE.TEDIT differ
diff --git a/internal/library/PEANO b/internal/library/PEANO
new file mode 100644
index 00000000..d0a985c3
--- /dev/null
+++ b/internal/library/PEANO
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "26-Jun-90 18:51:31" {DSK}<usr>local>lde>lispcore>internal>library>PEANO.;2 3337   

      changes to%:  (VARS PEANOCOMS)

      previous date%: " 8-Nov-88 14:27:45" {DSK}<usr>local>lde>lispcore>internal>library>PEANO.;1)


(* ; "
Copyright (c) 1982, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT PEANOCOMS)

(RPAQQ PEANOCOMS ((FNS PEANODEMO PEANOROTATE PEANO1 PEANOSTEP)
                      (MACROS PLOT)
                      
                      (* ;; "")

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

(PEANODEMO
  [LAMBDA (LEVEL SCALE)                                  (* rrb "31-MAY-82 12:16")
    (OR LEVEL (SETQ LEVEL 7))
    (COND
       (SCALE (SETQ PEANOSCALE (FIX SCALE)))
       ((FIXP PEANOSCALE))
       (T (SETQ PEANOSCALE 3)))
    (PROGN [COND
              ((TYPENAMEP PEANOWINDOW 'WINDOW))
              (T (SETQ PEANOWINDOW
                  (CREATEW (create REGION
                                  LEFT _ 624
                                  BOTTOM _ 402
                                  WIDTH _ 396
                                  HEIGHT _ 406)
                         "Peano curves"]
           (CLEARW PEANOWINDOW)
           (MOVETO PEANOSCALE PEANOSCALE PEANOWINDOW))
    (SETQ XNOW 1)
    (SETQ YNOW 1)
    (SETQ ORIENT 0)
    (PEANO1 LEVEL 1])

(PEANOROTATE
  [LAMBDA (DIRECTION)                                    (* bas%: "30-APR-82 19:29")
    (add ORIENT DIRECTION)
    (COND
       ((IGREATERP ORIENT 3)
        (SETQ ORIENT (IDIFFERENCE ORIENT 4)))
       ((ILESSP ORIENT 0)
        (SETQ ORIENT (IPLUS ORIENT 4])

(PEANO1
  [LAMBDA (LEVEL HAND)                                   (* rrb "31-MAY-82 13:17")
    (COND
       ((EQ LEVEL 1)
        (PLOT))
       (T (SETQ LEVEL (SUB1 LEVEL))
          (PEANOROTATE HAND)
          (PEANO1 LEVEL (IMINUS HAND))
          (PEANOSTEP)
          (PLOT)
          (PEANOSTEP)
          (PEANOROTATE (IMINUS HAND))
          (PEANO1 LEVEL HAND)
          (PEANOSTEP)
          (PLOT)
          (PEANOSTEP)
          (PEANO1 LEVEL HAND)
          (PEANOROTATE (IMINUS HAND))
          (PEANOSTEP)
          (PLOT)
          (PEANOSTEP)
          (PEANO1 LEVEL (IMINUS HAND))
          (PEANOROTATE HAND)
          (BLOCK])

(PEANOSTEP
  [LAMBDA NIL                                            (* rrb "31-MAY-82 11:31")
    (SELECTQ ORIENT
        (0 (SETQ XNOW (ADD1 XNOW)))
        (1 (SETQ YNOW (ADD1 YNOW)))
        (2 (SETQ XNOW (SUB1 XNOW)))
        (3 (SETQ YNOW (SUB1 YNOW)))
        (ERROR "Step: strange direction" ORIENT))
    (MOVETO (ITIMES XNOW PEANOSCALE)
           (ITIMES YNOW PEANOSCALE)
           PEANOWINDOW])
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS PLOT MACRO (NIL (RELDRAWTO PEANOSCALE 0 PEANOSCALE 'REPLACE PEANOWINDOW)))
)



(* ;; "")

(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS XNOW YNOW ORIENT PEANOSCALE PEANOWINDOW)
)

(RPAQQ PEANOSCALE 3)

(RPAQQ PEANOWINDOW NIL)
(PUTPROPS PEANO COPYRIGHT ("Venue & Xerox Corporation" 1982 1988 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (726 2957 (PEANODEMO 736 . 1527) (PEANOROTATE 1529 . 1819) (PEANO1 1821 . 2536) (
PEANOSTEP 2538 . 2955)))))
STOP
\ No newline at end of file
diff --git a/internal/library/PEANO.TEDIT b/internal/library/PEANO.TEDIT
new file mode 100644
index 00000000..34bf4bcc
Binary files /dev/null and b/internal/library/PEANO.TEDIT differ
diff --git a/internal/library/README b/internal/library/README
new file mode 100644
index 00000000..a3b56f13
--- /dev/null
+++ b/internal/library/README
@@ -0,0 +1 @@
+Files in this directory /usr/local/lde/internal/
where copied from {eris}<lispcore>internal>library>
31-Jan-90
\ No newline at end of file
diff --git a/internal/library/RELEASETOOLS b/internal/library/RELEASETOOLS
new file mode 100644
index 00000000..a4218415
--- /dev/null
+++ b/internal/library/RELEASETOOLS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED " 4-Jul-90 01:48:00" {ERINYES}<MEDLEY>1.2>INTERNAL>LIBRARY>RELEASETOOLS.\;1 66142  

      |changes| |to:|  (FNS LIBTOOL.MAKE.FLOPPIES LIBTOOL.MAKE.FLOPPIES.AUX LIBTOOL.BREAK.DEPENDENCY
                            LIBTOOL.FIND.FREE.FLOPPY LIBTOOL.WRITE.FILES LIBTOOL.CONFIRM.BREAK 
                            LIBTOOL.INITIALIZE.FLOPPY)
                       (VARS RELEASETOOLSCOMS)

      |previous| |date:| " 8-Nov-88 19:17:17" {ERINYES}<LISP>MEDLEY>INTERNAL>LIBRARY>RELEASETOOLS.\;1
)


; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT RELEASETOOLSCOMS)

(RPAQQ RELEASETOOLSCOMS ((COMS 
                                   (* |;;| "Making hardcopy-able directories and indexes;")

                                   (FNS COMPDIR FLOPPYDIR FLOPPYDIRECTORY FLOPPYINDEX FLOPPYINDEXAUX)
                                   )
                             (COMS 

                                 (* |;;| "These next functions all combine to make a tool for writing files on floppies. Call LIBTOOL.MAKE.FLOPPIES with a list of files (any dependent files in parens), e.g. ( (TEDIT.LCOM TEDITFILE.LCOM) (BROWSER.LCOM) . . .)")

                                   (FNS LIBTOOL.MAKE.FLOPPIES LIBTOOL.REQUEST.FLOPPY 
                                        LIBTOOL.MAKE.FLOPPIES.AUX LIBTOOL.BREAK.DEPENDENCY 
                                        LIBTOOL.FIND.FREE.FLOPPY LIBTOOL.WRITE.FILES 
                                        LIBTOOL.CONFIRM.BREAK LIBTOOL.INITIALIZE.FLOPPY)
                                   (RECORDS FLOPPY))
                             (COMS 

                                 (* |;;| " These next functions are used to compare the creation dates between two directories within a certain tolerance  (DATECOMP) is the only one called from the exec the others are supporting functions")

                                   (FNS DATECOMP COMPCRDA BOTHHAVE PRINT2LISTS)
                                   

                                 (* |;;| " WHATVER  creates a list of the version numbers for the source and Lcoms of files in a directory that make up a composite (usually a sysout) file")

                                   (FNS WHATVER)
                                   
                                   (* |;;| 
             "Given a list of files, return only those that are newer than a base directory's set.")

                                   (FNS SELECT-NEWER-FILES)
                                   
                                   (* |;;| 
                            "Check a directory to see if any files have both DFASL and LCOM files:")

                                   (FUNCTIONS LCOM-VS-DFASL))
                             (COMS 
                                   (* |;;| 
       "Verifying a group of floppies for validity against a specified set of release directories.")

                                   (FNS VERIFY-FLOPPIES))
                             (COMS 
                                   (* |;;| 
                              "Gather a unified list of where files are across several directories")

                                   (FNS CONSOLIDATED-DIRECTORIES CONSOLIDATED-DIRECTORY-LISTING)
                                   
                                   (* |;;| 
          "And based on the results of CONSOLIDATED-DIRECTORIES, move files to a single directory:")

                                   (FNS MOVE-TESTS))
                             (COMS 
                                   (* |;;| "Record success and failure in AR Test-Case runs")

                                   (COMMANDS "Pass" "Fail")
                                   (FUNCTIONS \\RECORD-AR-TEST-CASE-SUCCESS)
                                   (VARS (*AR-TEST-CASE-LOG-FILE* 
                                                "{ERIS}<Test>ARs>AR-TEST-CASE.Auto-log")
                                         (*AR-TEST-CASE-SUMMARY-TEMPLATE-FILE* 
                                                "{ERIS}<Test>ARs>AR-Test-Case-Summary-Template.TEdit"
                                                ))
                                   
                                   (* |;;| "Report generation functions")

                                   (FUNCTIONS AR-TEST-CASE-SUMMARY AR-TEST-CASE-READ 
                                          AR-FAILING-TEST-CASES))
                             (COMS 
                                   (* |;;| "Patch-file creation support.")

                                   
                                   (* |;;| 
                               "See {Eris}<Lispcore>Internal>Doc>Making-a-Patch.TEdit for details.")

                                   (COMMANDS "PATCH" "LIBPATCH" "LOGPATCH")
                                   (FNS \\MAKE-PATCH-FILE \\LOG-A-PATCH))
                             (PROP FILETYPE RELEASETOOLS)
                             (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
                                    (ADDVARS (NLAMA)
                                           (NLAML)
                                           (LAMA)))))



(* |;;| "Making hardcopy-able directories and indexes;")

(DEFINEQ

(COMPDIR
  (LAMBDA (DIR1 DIR2 DAYS PRINTFILENM ALLFILES)          (* \; "Edited 13-Apr-87 10:50 by lal")
                                                             (* \; "This function  determines the differences between the two specified directories.  It will check to see if all files exist on both directories, and if the creation date differences are within tolerances.")

    (LET ((PRINTFILE (OPENSTREAM PRINTFILENM 'OUTPUT 'NEW))
          (DIR1LIST NIL)
          (DIR2LIST 'NIL)
          (ANS NIL)
          (FILEN NIL))
         (PRINTOUT PRINTFILE "Discrepencies between  " DIR1 " and " DIR2 " (run on " (DATE)
                ")." T T)                                    (* \; "First check the creation date differences (which automatically checks that the files on DIR1 are on DIR2)")

         (PRINTOUT PRINTFILE "File" 20 "Author" T T)
         (|for| FILE |in| (COND
                                     (ALLFILES (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR1
                                                                 'NAME "*.*;")))
                                     (T (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR1 'NAME "*.;"))
                                        ))
            |do| (COND
                        ((EQUAL (UNPACKFILENAME.STRING FILE 'NAME)
                                "")
                         NIL)
                        (T (SETQ FILEN (COND
                                          ((EQUAL (CL:LENGTH (UNPACKFILENAME.STRING FILE 'DIRECTORY))
                                                  (CL:LENGTH (UNPACKFILENAME.STRING DIR1 'DIRECTORY))
                                                  )
                                           (UNPACKFILENAME.STRING FILE 'NAME))
                                          (T (CONCAT (SUBSTRING (UNPACKFILENAME.STRING FILE
                                                                       'DIRECTORY)
                                                            (+ (CL:LENGTH (UNPACKFILENAME.STRING
                                                                           DIR1
                                                                           'DIRECTORY))
                                                               2))
                                                    ">"
                                                    (UNPACKFILENAME.STRING FILE 'NAME)))))
                           (SETQ DIR2LIST (CADDR (COMPCRDA
                                                  DIR1 DIR2
                                                  (COND
                                                     (ALLFILES (COND
                                                                  ((EQUAL (UNPACKFILENAME.STRING
                                                                           FILE
                                                                           'EXTENSION)
                                                                          "")
                                                                   FILEN)
                                                                  (T (CONCAT FILEN "."
                                                                            (UNPACKFILENAME.STRING
                                                                             FILE
                                                                             'EXTENSION)))))
                                                     (T FILEN))
                                                  DAYS PRINTFILE DIR1LIST DIR2LIST))))))
                                                             (* \; 
                                                 "Then we check that the files on DIR2 are on DIR1")

         (|for| FILE |in| (COND
                                     (ALLFILES (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR2
                                                                 'NAME "*.*;")))
                                     (T (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR2 'NAME "*.;"))
                                        ))
            |do| (COND
                        ((EQUAL (UNPACKFILENAME.STRING FILE 'NAME)
                                "")
                         NIL)
                        (T (SETQ FILEN (COND
                                          ((EQUAL (CL:LENGTH (UNPACKFILENAME.STRING FILE 'DIRECTORY))
                                                  (CL:LENGTH (UNPACKFILENAME.STRING DIR2 'DIRECTORY))
                                                  )
                                           (UNPACKFILENAME.STRING FILE 'NAME))
                                          (T (CONCAT (SUBSTRING (UNPACKFILENAME.STRING FILE
                                                                       'DIRECTORY)
                                                            (+ (CL:LENGTH (UNPACKFILENAME.STRING
                                                                           DIR2
                                                                           'DIRECTORY))
                                                               2))
                                                    ">"
                                                    (UNPACKFILENAME.STRING FILE 'NAME)))))
                           (COND
                              ((CADR (BOTHHAVE DIR1 DIR2
                                            (COND
                                               (ALLFILES (COND
                                                            ((EQUAL (UNPACKFILENAME.STRING
                                                                     FILE
                                                                     'EXTENSION)
                                                                    "")
                                                             FILEN)
                                                            (T (CONCAT FILEN "." (
                                                                                UNPACKFILENAME.STRING
                                                                                  FILE
                                                                                  'EXTENSION)))))
                                               (T FILEN))
                                            DIR1LIST DIR2LIST))
                               (SETQ DIR1LIST
                                (CADR (BOTHHAVE DIR1 DIR2
                                             (COND
                                                (ALLFILES (COND
                                                             ((EQUAL (UNPACKFILENAME.STRING
                                                                      FILE
                                                                      'EXTENSION)
                                                                     "")
                                                              FILEN)
                                                             (T (CONCAT FILEN "." (
                                                                                UNPACKFILENAME.STRING
                                                                                   FILE
                                                                                   'EXTENSION)))))
                                                (T FILEN))
                                             DIR1LIST DIR2LIST))))))))
         (COND
            ((OR (GREATERP (LENGTH DIR1LIST)
                        0)
                 (GREATERP (LENGTH DIR2LIST)
                        0))
             (PRINTOUT PRINTFILE T T "Files not in" 30 "Files not in" T DIR1 30 DIR2 T T)))
         (PRINT2LISTS DIR1LIST DIR2LIST PRINTFILE)
         (CLOSEF PRINTFILE))))

(FLOPPYDIR
  (LAMBDA (DIR)                                              (* \; "Edited 19-Feb-87 19:32 by jds")
          
          (* |;;| 
          "Creates a TEdit window containing a DIRECTORY listing of DIR, or by default the FLOPPY.")

    (LET ((LISTINGFILE (OPENSTREAM '{NODIRCORE} 'BOTH)))
         (DIRECTORY (OR DIR '{FLOPPY})
                `(OUT ,LISTINGFILE P DA))
         (COND
            ((NOT (OPENP LISTINGFILE))
             (SETQ LISTINGFILE (OPENSTREAM LISTINGFILE 'INPUT))))
         (SETFILEPTR LISTINGFILE 0)
         (TEDIT LISTINGFILE))))

(floppydirectory
  (lambda (|ListFile|)                                       (* \; "Edited  4-Mar-87 09:32 by shw:")
          
          (* |;;| 
          "Makes a TEdit file (listfile) that contains a formatted list of what is on the floppy;")

    (prog (strm names f.name)
          (|if| (not |ListFile|)
              |then| (|printout| t "PLEASE GIVE OUTPUT FILE NAME" t)
                    (return nil)
            |else| (setq strm (opentextstream)))
          (|until| (mouseconfirm "Please insert floppy.") |do| (block))
          (setq names (fildir '{floppy}))
          (setq f.name (floppy.name))
          (tedit.insert strm (concat (character 13)
                                    "Contents of "
                                    (if (eq (machinetype)
                                            'dove)
                                        then "1186"
                                      else "1108")
                                    " Floppy: " f.name (character 13)
                                    (character 13))
                 nil
                 (fontcreate 'timesroman 12 'bold))
          (|for| x |in| names |do| (tedit.insert strm (concat (packfilename 'host nil 'body x)
                                                             (character 13))
                                          nil
                                          (fontcreate 'gacha 10)))
          (tedit.paralooks (textobj strm)
                 '(quad centered) 1 12)
          (tedit.looks (textobj strm)
                 '(underline on) 2 (nchars (concat "Contents of Floppy: " f.name)))
          (closef strm)
          (tedit.put strm |ListFile|)
          (return |ListFile|))))

(floppyindex
  (lambda (outfile)                                          (* \; "Edited 14-Jan-87 14:03 by shw:")

(* |;;;| "Given a series of library-package floppies, creates a directory showing where each library file resides, sorted alphabetically by library filename.  Prints the list on OUTFILE, and returns a list of ((LIBNAME FLOPPY) (LIBNAME2 FLOPPY2) ...)")

    (prog (floppycontents packagelocs wasopen)
          
          (* |;;| 
          " Ask the person to load each floppy in turn.  Collect the DIRECTORY off each floppy.")

          (setq floppycontents (|collect| (|until| (mouseconfirm (concat "Load data for " (
                                                                                          floppy.name
                                                                                           )
                                                                        "?")) |do| (block))
                                      (cons (floppy.name)
                                            (directory '{floppy})) |repeatwhile| (mouseconfirm 
                          "Click LEFT once you have loaded another floppy, RIGHT if you want to end."
                                                                                        )))
          (setq floppycontents (intersection floppycontents floppycontents))
                                                             (* \; 
                      "Now make sure we have no duplicates, in case he loaded the same floppy twice.")
          (setq packagelocs (|for| floppy |in| floppycontents
                               |join| 
          
          (* |;;| "Gather the root filenames for the files on eadh floppy")

                                     (|bind| (floppyname _ (car floppy)) |for| package
                                        |in| (cdr floppy) |collect| 
          
          (* |;;| 
          "collect the root file name for each file on the floppy together with the floppy's name.")

                                                                (list (packfilename 'version nil
                                                                             'host nil 'directory
                                                                             'nil
                                                                             'body package)
                                                                      floppyname))))
          (floppyindexaux outfile packagelocs)               (* \; "Print the directory")
          (return outfile))))

(FLOPPYINDEXAUX
  (LAMBDA (OUTFILE PACKAGELOCS)                          (* \; "Edited 12-Feb-87 14:29 by shw:")

    (* |;;| "Given a list of the form ((pkgName floppyName) (pkgName floppyName) etc.), print an alphabetized listing with package names on the left, and floppy names on the right.  Prints the listing on OUTFILE, which is, if need be, opened and closed.")

    (PROG (FLOPPYCONTENTS WASOPEN)
          (COND
             ((OPENP OUTFILE)
              (SETQ WASOPEN T))
             (T (SETQ OUTFILE (OPENSTREAM OUTFILE 'OUTPUT 'NEW))))
          (SETQ PACKAGELOCS (INTERSECTION PACKAGELOCS PACKAGELOCS))
          (SETQ PACKAGELOCS (SORT PACKAGELOCS '(LAMBDA (PKG1 PKG2)
                                                 (UALPHORDER (CAR PKG1)
                                                        (CAR PKG2)))))
          (|for| PKG |in| PACKAGELOCS |do| (|pushnew| FLOPPYCONTENTS (CADR PKG)))
          (|for| PKG |in| PACKAGELOCS |first| (PRINTOUT OUTFILE T
                                                                 (|if| (EQ (MACHINETYPE)
                                                                               'DOVE)
                                                                     |then| "1186"
                                                                   |else| "1108")
                                                                 " >>NAME<< " 
                                                                 "Module name to floppy directory" T
                                                                 T "Created from floppies named:  ")
                                                    (|for| FLOPPY |in| (SORT FLOPPYCONTENTS)
                                                       |do| (PRINTOUT OUTFILE FLOPPY \,)
                                                       |finally| (PRINTOUT OUTFILE T T))
             |do| (PRINTOUT OUTFILE (PACKFILENAME 'VERSION NIL 'BODY (CAR PKG))
                             "	"
                             (CADR PKG)
                             T))
          (COND
             ((NOT WASOPEN)
              (CLOSEF OUTFILE))))))
)



(* |;;| 
"These next functions all combine to make a tool for writing files on floppies. Call LIBTOOL.MAKE.FLOPPIES with a list of files (any dependent files in parens), e.g. ( (TEDIT.LCOM TEDITFILE.LCOM) (BROWSER.LCOM) . . .)"
)

(DEFINEQ

(LIBTOOL.MAKE.FLOPPIES
  (LAMBDA (FILELIST FROMDIR FLOPPYSIZE FLOPPY-NAME-BASE) (* |edited:| "24-Oct-86 16:21")

    (* |;;| "Request a floppy.  Initialize the first floppy Call the aux function which will do the rest of the work on that group.")

    (LET ((FLOPSIZE (IF (OR (EQUAL FLOPPYSIZE 8)
                                (EQUAL FLOPPYSIZE 1108))
                        THEN 2250
                      ELSE 690)))
         (SETQ FLOPPYLIST NIL)                               (* \; "Start with no known floppies.")

         (* |;;| "Ask for the first floppy, and format it, if needed.")

         (LIBTOOL.INITIALIZE.FLOPPY FLOPPYSIZE FLOPPY-NAME-BASE)
         (|for| GROUP |in| FILELIST |do| (LIBTOOL.MAKE.FLOPPIES.AUX GROUP FROMDIR 
                                                            FLOPSIZE FLOPPY-NAME-BASE)))))

(libtool.request.floppy
  (lambda (floppynum)                                        (* |edited:| "27-Oct-86 14:15")
    (ringbells)
    (printout t "Please insert " floppynum t "Is the requested floppy ready? ")
    (let ((answer (read)))
         (|if| (not (or (equal answer 'y)
                        (equal answer '\y)))
             |then| (libtool.request.floppy floppynum)
           |else| (printout t "Floppy accepted." t)))))

(LIBTOOL.MAKE.FLOPPIES.AUX
  (LAMBDA (GROUP FROMDIR FLOPSIZE FLOPPY-NAME-BASE)  (* \; "Edited 30-Dec-86 10:09 by Wessling")

    (* |;;| "Given a list of files to be written together on one floppy (or a single symbol that's a single file), find space and write the files.  If there's not room for all the files on a single floppy, split the list (and let the user confirm that he wants it busted as we say).")

    (SETQ GROUP (MKLIST GROUP))                              (* \; 
                                                           "Single file -> List of file(s).")
    (LET ((FILELENGTH (|for| FILE |in| GROUP |sum| (GETFILEINFO (PACK* FROMDIR FILE)
                                                                      'SIZE))))

         (* |;;| "If the file length is greater than 687, then the group of files is going to have to be broken.  Call LIBTOOL.BREAK.DEPENDENCY to split them up.")

         (|if| (GREATERP (PLUS FILELENGTH (TIMES 2 (LENGTH GROUP)))
                          FLOPSIZE)
             |then| (LIBTOOL.BREAK.DEPENDENCY (REMOVE (CAR (LAST GROUP))
                                                             GROUP)
                               (LAST GROUP)
                               (GETFILEINFO (PACK* FROMDIR (CAR (LAST GROUP)))
                                      'SIZE)
                               FROMDIR FLOPSIZE FLOPPY-NAME-BASE)
           |else| (|if| (LESSP FILELENGTH (|fetch| FREEPAGES |of| CURRENTFLOPPY))
                          |then| (LIBTOOL.WRITE.FILES (|if| (LISTP GROUP)
                                                                  |then| GROUP
                                                                |else| (LIST GROUP))
                                            FROMDIR FLOPSIZE)
                        |else| (LIBTOOL.FIND.FREE.FLOPPY FILELENGTH GROUP FLOPSIZE 
                                          FLOPPY-NAME-BASE)
                              (LIBTOOL.WRITE.FILES (|if| (LISTP GROUP)
                                                           |then| GROUP
                                                         |else| (LIST GROUP))
                                     FROMDIR FLOPSIZE))))))

(LIBTOOL.BREAK.DEPENDENCY
  (LAMBDA (GROUP LASTFILE LENGTHLASTFILE FROMDIR FLOPSIZE FLOPPY-NAME-BASE)
                                                             (* |edited:| "24-Oct-86 17:15")

    (* |;;| 
  "Find a combo of files that will fit on one floppy.  Return 2 lists: that combo and the rest.")

    (|if| (GREATERP (PLUS LENGTHLASTFILE (GETFILEINFO (PACK* FROMDIR (CAR (LAST GROUP)))
                                                    'SIZE))
                     FLOPSIZE)
        |then| (LIBTOOL.CONFIRM.BREAK GROUP LASTFILE FROMDIR FLOPSIZE FLOPPY-NAME-BASE)
      |else| (LIBTOOL.BREAK.DEPENDENCY (REMOVE (CAR (LAST GROUP))
                                                      GROUP)
                        (APPEND (LAST GROUP)
                               LASTFILE)
                        (PLUS LENGTHLASTFILE (GETFILEINFO (PACK* FROMDIR (CAR (LAST GROUP)))
                                                    'SIZE))
                        FROMDIR FLOPSIZE FLOPPY-NAME-BASE))))

(LIBTOOL.FIND.FREE.FLOPPY
  (LAMBDA (PAGESNEEDED GROUP FLOPSIZE FLOPPY-NAME-BASE)  (* |edited:| "27-Oct-86 15:24")

    (* |;;| "Hunt for a floppy that has enough space for the files we want to write (PAGESNEEDED).")

    (* |;;| "If the floppylist is empty, create a new floppy record and request a new floppy.")

    (LET ((NEWFLOP (|for| FLOPPY |in| FLOPPYLIST |thereis| (LESSP PAGESNEEDED
                                                                              (|fetch| FREEPAGES
                                                                                 |of| FLOPPY)))))
         (|if| (NULL NEWFLOP)
             |then| (LIBTOOL.INITIALIZE.FLOPPY FLOPSIZE FLOPPY-NAME-BASE)
           |else| (LIBTOOL.REQUEST.FLOPPY (|fetch| NAME |of| NEWFLOP))
                 (SETQ CURRENTFLOPPY NEWFLOP)))              (* \; 
 "If it finds a floppy that has enough room, it should return back with that floppy it and resume.")
    (FOR X INFILES "{FLOPPY}*" COLLECT X)))

(LIBTOOL.WRITE.FILES
  (LAMBDA (GROUP FROMDIR FLOPSIZE)                       (* |edited:| "24-Oct-86 16:34")

    (* |;;| "Write the files onto the floppy.")

    (|for| FILE |in| GROUP |do| (PRINTOUT T "Copying " FILE " to " (|fetch| NAME
                                                                                  |of| 
                                                                                        CURRENTFLOPPY
                                                                                      )
                                                   "..." T)
                                         (COPYFILE (PACK* FROMDIR FILE)
                                                (PACK* '{FLOPPY} FILE)))
    (PRINTOUT T " ...done." T)

    (* |;;| "Update the prop list of that floppy to know that there are fewer pages:")

    (|replace| FREEPAGES |of| CURRENTFLOPPY |with| (FLOPPY.FREE.PAGES))))

(LIBTOOL.CONFIRM.BREAK
  (LAMBDA (GROUP1 GROUP2 FROMDIR FLOPSIZE FLOPPY-NAME-BASE)
                                                             (* |edited:| "27-Oct-86 15:40")

    (* |;;| 
"Let the user confirm a suggested breakdown of a group of files that won't fit on a single floppy.")

    (PRINTOUT T "Group must be broken. Breakup will be:" T T GROUP1 T T GROUP2 T T)
    (PRINTOUT T "Please confirm: ")
    (LET ((ANSWER (READ)))
         (|if| (OR (EQUAL ANSWER 'Y)
                       (EQUAL ANSWER '\y))
             |then| (|for| GROUP |in| (LIST GROUP1 GROUP2)
                           |do| (LIBTOOL.MAKE.FLOPPIES.AUX GROUP FROMDIR FLOPSIZE 
                                           FLOPPY-NAME-BASE))
           |else| (PRINTOUT T "Please enter your split, typing the two groups as lists:" T)
                 (PRINTOUT T "Please type first group: ")
                 (LET ((SPLIT1 (READ)))
                      (PRINTOUT T "Please type second group: ")
                      (LET ((SPLIT2 (READ)))
                           (|for| GROUP |in| (LIST SPLIT1 SPLIT2)
                              |do| (LIBTOOL.MAKE.FLOPPIES.AUX GROUP FROMDIR FLOPSIZE 
                                              FLOPPY-NAME-BASE))))))))

(LIBTOOL.INITIALIZE.FLOPPY
  (LAMBDA (FLOPSIZE FLOPPY-NAME-BASE)                    (* |edited:| "24-Oct-86 17:12")

    (* |;;| "Ask the user to insert a NEW floppy (not one that we've written on before).  Assign it the next number n the series, and format it, if he specified a name.")

    (LET ((NEWFLOPPY (CONCAT (OR FLOPPY-NAME-BASE 'FLOPPY)
                            " #"
                            (ADD1 (LENGTH FLOPPYLIST)))))

         (* |;;| "Get the new floppy inserted:")

         (LIBTOOL.REQUEST.FLOPPY NEWFLOPPY)

         (* |;;| 
       "Now format it, if he gave us a name (if not, assume he formatted the floppies himself):")

         (AND FLOPPY-NAME-BASE (FLOPPY.FORMAT NEWFLOPPY NIL T))

         (* |;;| 
       "Create the description for this new floppy, and add it to the list of known floppies:")

         (SETQ CURRENTFLOPPY (|create| FLOPPY
                                    NAME _ NEWFLOPPY
                                    FREEPAGES _ FLOPSIZE))
         (SETQ FLOPPYLIST (NCONC1 FLOPPYLIST CURRENTFLOPPY)))))
)
(DECLARE\: EVAL@COMPILE

(RECORD FLOPPY (NAME FREEPAGES))
)



(* |;;| 
" These next functions are used to compare the creation dates between two directories within a certain tolerance  (DATECOMP) is the only one called from the exec the others are supporting functions"
)

(DEFINEQ

(DATECOMP
  (LAMBDA (DIR1 DIR2 DAYS PRINTFILENM ALLFILES)              (* \; "Edited 13-Apr-87 10:50 by lal")
                                                             (* \; "This function  determines the differences between the two specified directories.  It will check to see if all files exist on both directories, and if the creation date differences are within tolerances.")
    (LET
     ((PRINTFILE (OPENSTREAM PRINTFILENM 'OUTPUT 'NEW))
      (DIR1LIST NIL)
      (DIR2LIST 'NIL)
      (ANS NIL)
      (FILEN NIL))
     (PRINTOUT PRINTFILE "Discrepencies between  " DIR1 " and " DIR2 " (run on " (DATE)
            ")." T T)                                        (* \; "First check the creation date differences (which automatically checks that the files on DIR1 are on DIR2)")
     (PRINTOUT PRINTFILE "File" 20 "Author" T T)
     (|for| FILE |in| (|if| ALLFILES
                          |then| (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR1 'NAME "*.*;"))
                        |else| (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR1 'NAME "*.;")))
        |do| (|if| (EQUAL (UNPACKFILENAME.STRING FILE 'NAME)
                          "")
                 |then| NIL
               |else| (SETQ FILEN (|if| (EQUAL (CL:LENGTH (UNPACKFILENAME.STRING FILE 'DIRECTORY))
                                               (CL:LENGTH (UNPACKFILENAME.STRING DIR1 'DIRECTORY)))
                                      |then| (UNPACKFILENAME.STRING FILE 'NAME)
                                    |else| (CONCAT (SUBSTRING (UNPACKFILENAME.STRING FILE
                                                                     'DIRECTORY)
                                                          (+ (CL:LENGTH (UNPACKFILENAME.STRING
                                                                         DIR1
                                                                         'DIRECTORY))
                                                             2))
                                                  ">"
                                                  (UNPACKFILENAME.STRING FILE 'NAME))))
                     (SETQ DIR2LIST
                      (CADDR (COMPCRDA DIR1 DIR2 (|if| ALLFILES
                                                     |then| (|if| (EQUAL (UNPACKFILENAME.STRING
                                                                          FILE
                                                                          'EXTENSION)
                                                                         "")
                                                                |then| FILEN
                                                              |else| (CONCAT FILEN "."
                                                                            (UNPACKFILENAME.STRING
                                                                             FILE
                                                                             'EXTENSION)))
                                                   |else| FILEN)
                                    DAYS PRINTFILE DIR1LIST DIR2LIST)))))
                                                             (* \; 
                                                   "Then we check that the files on DIR2 are on DIR1")
     (|for| FILE |in| (|if| ALLFILES
                          |then| (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR2 'NAME "*.*;"))
                        |else| (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR2 'NAME "*.;")))
        |do|
        (|if| (EQUAL (UNPACKFILENAME.STRING FILE 'NAME)
                     "")
            |then| NIL
          |else| (SETQ FILEN (|if| (EQUAL (CL:LENGTH (UNPACKFILENAME.STRING FILE 'DIRECTORY))
                                          (CL:LENGTH (UNPACKFILENAME.STRING DIR2 'DIRECTORY)))
                                 |then| (UNPACKFILENAME.STRING FILE 'NAME)
                               |else| (CONCAT (SUBSTRING (UNPACKFILENAME.STRING FILE 'DIRECTORY)
                                                     (+ (CL:LENGTH (UNPACKFILENAME.STRING
                                                                    DIR2
                                                                    'DIRECTORY))
                                                        2))
                                             ">"
                                             (UNPACKFILENAME.STRING FILE 'NAME))))
                (|if| (CADR (BOTHHAVE DIR1 DIR2 (|if| ALLFILES
                                                    |then| (|if| (EQUAL (UNPACKFILENAME.STRING
                                                                         FILE
                                                                         'EXTENSION)
                                                                        "")
                                                               |then| FILEN
                                                             |else| (CONCAT FILEN "."
                                                                           (UNPACKFILENAME.STRING
                                                                            FILE
                                                                            'EXTENSION)))
                                                  |else| FILEN)
                                   DIR1LIST DIR2LIST))
                    |then| (SETQ DIR1LIST
                            (CADR (BOTHHAVE DIR1 DIR2
                                         (|if| ALLFILES
                                             |then| (|if| (EQUAL (UNPACKFILENAME.STRING FILE
                                                                        'EXTENSION)
                                                                 "")
                                                        |then| FILEN
                                                      |else| (CONCAT FILEN "." (UNPACKFILENAME.STRING
                                                                                FILE
                                                                                'EXTENSION)))
                                           |else| FILEN)
                                         DIR1LIST DIR2LIST))))))
     (|if| (OR (GREATERP (LENGTH DIR1LIST)
                      0)
               (GREATERP (LENGTH DIR2LIST)
                      0))
         |then| (PRINTOUT PRINTFILE T T "Files not in" 30 "Files not in" T DIR1 30 DIR2 T T))
     (PRINT2LISTS DIR1LIST DIR2LIST PRINTFILE)
     (CLOSEF PRINTFILE))))

(COMPCRDA
  (LAMBDA (DIR1 DIR2 DCFILE DAYS PRINTFILE DIR1LIST DIR2LIST)(* \; "Edited  5-Feb-87 17:39 by lal")
                                                             (* \; "This function finds the difference between the creation dates of the given file in both directories")
    (COND
       ((CAR (BOTHHAVE DIR1 DIR2 DCFILE DIR1LIST DIR2LIST))
        (COND
           ((IGREATERP (ABS (DIFFERENCE (GETFILEINFO (PACKFILENAME.STRING 'DIRECTORY DIR1
                                                            'NAME DCFILE)
                                               'ICREATIONDATE)
                                   (GETFILEINFO (PACKFILENAME.STRING 'DIRECTORY DIR2 'NAME DCFILE)
                                          'ICREATIONDATE)))
                   (TIMES DAYS 24 60 60))
            (PRINTOUT PRINTFILE DCFILE 20 (GETFILEINFO (PACKFILENAME.STRING 'DIRECTORY DIR2
                                                              'NAME DCFILE)
                                                 'AUTHOR)
                   T)                                        (* \; 
                      "Testing to see if the difference is greater than the specified number of days")
            (LIST NIL DIR1LIST DIR2LIST))
           (T (LIST NIL DIR1LIST DIR2LIST))))
       (T (BOTHHAVE DIR1 DIR2 DCFILE DIR1LIST DIR2LIST)))))

(BOTHHAVE
  (LAMBDA (DIR1 DIR2 FILENM DIR1LIST DIR2LIST)               (* \; "Edited 10-Apr-87 11:51 by lal")
                                                             (* \; "This function checks to see if both directories have the specified file on them and return them in an appropriate list.")
    (COND
       ((FINDFILE FILENM T (LIST DIR1))
        (COND
           ((FINDFILE FILENM T (LIST DIR2))
            (LIST T NIL NIL))
           (T (LIST NIL NIL (APPEND DIR2LIST (LIST FILENM))))))
       (T (LIST NIL (APPEND DIR1LIST (LIST FILENM)))))))

(PRINT2LISTS
  (LAMBDA (FIRST SECOND PRINTFILE)                           (* \; "Edited  5-Feb-87 11:11 by lal")
                                                             (* \; 
                                "This function will print the elements of two lists in tow columns. ")
    (LET ((NUM (MAX (LENGTH FIRST)
                    (LENGTH SECOND))))
         (|for| X |from| 1 |to| NUM |do| (|if| (CAR FIRST)
                                             |then| (PRINTOUT PRINTFILE (CAR FIRST)) 
                                                             (* \; 
                                                             "print an element for the 1st column")
                                                   (SETQ FIRST (CDR FIRST)))
                                         (|if| (CAR SECOND)
                                             |then| (PRINTOUT PRINTFILE 30 (CAR SECOND)
                                                           T) 
                                                             (* \; 
                                                             " print an element for the 2nd column")
                                                   (SETQ SECOND (CDR SECOND))
                                           |else| (PRINTOUT PRINTFILE T))))))
)



(* |;;| 
" WHATVER  creates a list of the version numbers for the source and Lcoms of files in a directory that make up a composite (usually a sysout) file"
)

(DEFINEQ

(WHATVER
  (LAMBDA (DIR1 COMPOUND PRINTFILENM)                        (* \; "Edited 10-Apr-87 09:56 by lal")
                                                             (* \; "This function exists to record the versions of all the source and compiled  files that make up a compound file for later comparison")
    (LET ((OLDFILE NIL)
          (PRINTFILE (OPENSTREAM PRINTFILENM 'OUTPUT 'NEW))
          (COMPILE-EXTEN '("LCOM" "DFASL")))
         (PRINTOUT PRINTFILE "This program will find the version numbers for files that make up a particular sysout or patch. (run on "
                (DATE)
                ")." T T)                                    (* \; "printing out headings")
         (PRINTOUT PRINTFILE "The compound file is " (CAR (DIRECTORY COMPOUND))
                " created on "
                (GETFILEINFO COMPOUND 'CREATIONDATE)
                T)
         (PRINTOUT PRINTFILE T "FILE" 27 "SOURCE" 36 "COMPILED" T 27 "VERSION" 37 "VERSION")
                                                             (* \; "print each unique filename")
         (|for| FILE |in| (SORT (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR1 'NAME "*.*;")))
            |do|                                             (* \; 
                                             "only process the files that are either source or Lcoms")
                 (|if| (OR (EQUAL (UNPACKFILENAME.STRING FILE 'EXTENSION)
                                  "")
                           (MEMBER (UNPACKFILENAME.STRING FILE 'EXTENSION)
                                  COMPILE-EXTEN))
                     |then|                                  (* \; "Is this a different file ?")
                           (|if| (OR (NOT (EQUAL (UNPACKFILENAME.STRING FILE 'NAME)
                                                 (UNPACKFILENAME.STRING OLDFILE 'NAME)))
                                     (NULL OLDFILE))
                               |then| (|if| (AND OLDFILE (NOT (MEMBER (UNPACKFILENAME.STRING
                                                                       OLDFILE
                                                                       'EXTENSION)
                                                                     COMPILE-EXTEN)))
                                          |then|             (* \; "if we found the next file but there was no Lcom for the previous one, print out a dash in the Lcom column for the last file")
                                                (PRINTOUT PRINTFILE 40 "-")) 
                                                             (* \; " print out next file name")
                                     (PRINTOUT PRINTFILE T (UNPACKFILENAME.STRING FILE 'NAME)))
                           (|if| (EQUAL (UNPACKFILENAME.STRING FILE 'EXTENSION)
                                        "")
                               |then|                        (* \; 
                               "if it is a source file print its version number in the proper column")
                                     (PRINTOUT PRINTFILE 30 (UNPACKFILENAME.STRING FILE 'VERSION)))
                           (|if| (MEMBER (UNPACKFILENAME.STRING FILE 'EXTENSION)
                                        COMPILE-EXTEN)
                               |then|                        (* \; 
                    "if we found the Lcom but there was no source, print a dash in the source column")
                                     (|if| (NOT (EQUAL (UNPACKFILENAME.STRING OLDFILE 'EXTENSION)
                                                       ""))
                                         |then| (PRINTOUT PRINTFILE 30 "-")) 
                                                             (* \; 
                                        "print the compiled file version number in its proper column")
                                     (PRINTOUT PRINTFILE 40 (UNPACKFILENAME.STRING FILE 'VERSION)))
                           (SETQ OLDFILE FILE)))
         (CLOSEF PRINTFILE))))
)



(* |;;| "Given a list of files, return only those that are newer than a base directory's set.")

(DEFINEQ

(SELECT-NEWER-FILES
  (LAMBDA (FILE-LIST BASE-DIRECTORY)                     (* \; "Edited 21-Jan-88 09:46 by jds")

    (PRINTOUT T T "- - - - Gathering newer files - - - -" T T)
    (|bind| OTHERFILE |for| FILE |in| FILE-LIST
       |when| (COND
                     ((NOT (INFILEP (SETQ OTHERFILE (PACKFILENAME 'VERSION NIL 'DIRECTORY 
                                                           BASE-DIRECTORY 'BODY FILE))))
                                                             (* \; "New file.")

                      (PRINTOUT T "   NEW file:  " FILE T)
                      FILE)
                     ((> (GETFILEINFO FILE 'ICREATIONDATE)
                         (GETFILEINFO OTHERFILE 'ICREATIONDATE))
                                                             (* \; "This file is newer.")

                      (PRINTOUT T "   Newer file collected:  " FILE T)
                      FILE)
                     (T (PRINTOUT T "   Not collected:  " FILE T)
                        NIL)) |collect| (LIST FILE (GETFILEINFO FILE 'CREATIONDATE)))))
)



(* |;;| "Check a directory to see if any files have both DFASL and LCOM files:")


(CL:DEFUN LCOM-VS-DFASL (DIRECTORY &OPTIONAL DRIBBLE?)
   (LET ((FILES (DIRECTORY DIRECTORY))
         LCOM DFASL)
        (SETQ FILES (|for| FILE |in| FILES |collect| (PACKFILENAME 'EXTENSION NIL
                                                                        'VERSION NIL 'BODY FILE)))
        (SETQ FILES (INTERSECTION FILES FILES))
        (COND
           (DRIBBLE? (DRIBBLE '{CORE}LCOM-VS-DFASL-CHECKOUT)))
        (COND
           (FILES (PRINTOUT T T T "- - - Checking " DIRECTORY " for DFASL/LCOM conflict - - -" T T))
           (T (PRINTOUT T T T "- - - " DIRECTORY " has no DFASL/LCOM conflicts - - -" T T)))
        (|for| FILE |in| FILES |when| (AND (INFILEP (SETQ LCOM (PACKFILENAME 'EXTENSION 
                                                                                  "LCOM" 'BODY FILE))
                                                              )
                                                       (INFILEP (SETQ DFASL (PACKFILENAME
                                                                             'EXTENSION "DFASL"
                                                                             'BODY FILE))))
           |do| (PRINTOUT T "   " FILE " [" (GETFILEINFO FILE 'AUTHOR)
                           "] has both LCOM & DFASL ")
                 (COND
                    ((>= (GETFILEINFO LCOM 'ICREATIONDATE)
                         (GETFILEINFO DFASL 'ICREATIONDATE))
                     (PRINTOUT T "(the LCOM is newer)." T))
                    (T (PRINTOUT T "(the DFASL is newer)." T))))
        (COND
           (DRIBBLE? (DRIBBLE NIL)
                  (SEND.FILE.TO.PRINTER '{CORE}LCOM-VS-DFASL-CHECKOUT)
                  (DELFILE '{CORE}LCOM-VS-DFASL-CHECKOUT)))))



(* |;;| "Verifying a group of floppies for validity against a specified set of release directories."
)

(DEFINEQ

(VERIFY-FLOPPIES
  (LAMBDA (RELEASE-DIRECTORY-LIST)                       (* \; "Edited 19-Feb-88 14:35 by jds")
          
          (* |;;| "This function will repeatedly ask for floppy disks, and for each will")
          
          (* |;;| "    -- Verify that it can read the directory")
          
          (* |;;| "    -- Pick a file at random and compare it with the corresponding file in the release directories.")
          
          (* |;;| "RELEASE-DIRECTORY-LIST is a single directory name or a list of directories where the originals of the files on each floppy reside.  These directories are searched (in order) to find equivalent files for comparison.")

    (LET ((DIR-LIST (OR (LISTP RELEASE-DIRECTORY-LIST)
                        (LIST RELEASE-DIRECTORY-LIST)))
          FLOPPY-DIR TEST-FILE EQUIVALENT-FILE)
         (DRIBBLE '{LPT}FLOPPY-VERIFICATION-RESULTS)
         (|for| FLOPPY# |from| 1 |while| (MOUSECONFIRM 
                                                           "Click LEFT when next floppy is in drive."
                                                            )
            |do| (PRINTOUT T T T "- - - - - - - - - - - Verifying Floppy #" FLOPPY# 
                            " - - - - - - - - - - -" T T)
                  (SETQ FLOPPY-DIR (DIRECTORY "{FLOPPY}"))
                  (PRINTOUT T "     * Directory read successfully" T)
                  (SETQ TEST-FILE (CL:NTH (RAND 0 (CL:1- (LENGTH FLOPPY-DIR)))
                                         FLOPPY-DIR))
                  (SETQ EQUIVALENT-FILE (FINDFILE (PACKFILENAME.STRING 'VERSION NIL 'HOST NIL
                                                         'DIRECTORY NIL 'BODY TEST-FILE)
                                               NIL RELEASE-DIRECTORY-LIST))
                  (COND
                     (EQUIVALENT-FILE (PRINTOUT T "     * Comparing " TEST-FILE " vs. " 
                                             EQUIVALENT-FILE " ... ")
                            (COMPAREFILES TEST-FILE EQUIVALENT-FILE)
                            (PRINTOUT T "done." T))
                     (T (PRINTOUT T "     ****NO EQUIVALENT FOUND FOR " TEST-FILE T)))))))
)



(* |;;| "Gather a unified list of where files are across several directories")

(DEFINEQ

(CONSOLIDATED-DIRECTORIES
  (LAMBDA (DIR-LIST)                                     (* \; "Edited 12-Feb-88 13:34 by jds")
          
          (* |;;| 
     "Create a consolidated listing of all occurrances of a given file across several directories.")

    (LET ((FULL-DIR-NAMES (|for| DIR |in| DIR-LIST
                             |collect| (COND
                                              ((OR (UNPACKFILENAME DIR 'NAME)
                                                   (UNPACKFILENAME DIR 'EXTENSION)
                                                   (UNPACKFILENAME DIR 'VERSION))
                                                             (* \; 
                                             "A name of some sort got specified.  Use his pattern.")

                                               DIR)
                                              (T             (* \; "Default the pattern to *.*;.")

                                                 (PACKFILENAME.STRING 'DIRECTORY DIR 'NAME "*.*;"))))
                 )
          FILE-NAME FILE-LIST FILE-NAMES FILE-PLIST FILE-INFO)
         (|for| DIR |in| FULL-DIR-NAMES
            |do| (|for| FILE |in| (DIRECTORY DIR)
                        |do| (SETQ FILE-NAME (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'VERSION NIL
                                                        'BODY FILE))
                              (CL:PUSH (LIST FILE (GETFILEINFO FILE 'CREATIONDATE))
                                     (CL:GETF FILE-LIST FILE-NAME))
                              (CL:PUSHNEW FILE-NAME FILE-NAMES)))
         (SETQ FILE-NAMES (SORT FILE-NAMES))
         (|for| NAME |in| FILE-NAMES |collect| (CONS NAME (CL:GETF FILE-LIST NAME))))))

(CONSOLIDATED-DIRECTORY-LISTING
  (LAMBDA (DIR-LIST PRINT-FILE)                          (* \; "Edited 11-Feb-88 17:19 by jds")

    (LET ((SORTED-LIST (CONSOLIDATED-DIRECTORIES DIR-LIST))
          (BOLDFONT (FONTCREATE 'OPTIMA 10 'BOLD NIL 'INTERPRESS))
          (SMALLFONT (FONTCREATE 'OPTIMA 7 NIL NIL 'INTERPRESS)))
         (CL:WITH-OPEN-STREAM (PRINT (OPENIMAGESTREAM (OR PRINT-FILE "{LPT}")
                                            'INTERPRESS))
                (FOR FILE-INFO IN SORTED-LIST DO (DSPFONT BOLDFONT PRINT)
                                                            (PRINTOUT PRINT T (CAR FILE-INFO)
                                                                   T)
                                                            (DSPFONT SMALLFONT PRINT)
                                                            (FOR FILE IN (CDR FILE-INFO)
                                                               DO (PRINTOUT PRINT 10 (CAR FILE)
                                                                             " ("
                                                                             (CADR FILE)
                                                                             ")" T)))))))
)



(* |;;| "And based on the results of CONSOLIDATED-DIRECTORIES, move files to a single directory:")

(DEFINEQ

(MOVE-TESTS
  (LAMBDA (TEST-LIST TEST-DIR)                           (* \; "Edited 15-Feb-88 14:18 by jds")
          
          (* |;;| "Move tests onto TEST-DIR.")

    (LET (FILE-NAME FILE-INSTANCES)
         (|for| FILE |in| TEST-LIST
            |do| (DESTRUCTURING-BIND (FILE-NAME . FILE-INSTANCES)
                            FILE
                            (COND
                               ((> (LENGTH FILE-INSTANCES 1))
          
          (* |;;| "More than one.  Sort them downward by creation date.")

                                (SETQ FILE-INSTANCES (CL:SORT FILE-INSTANCES #'> :KEY
                                                            '(LAMBDA (FILE-INSTANCE)
                                                               (IDATE (CADR FILE-INSTANCE)))))
                                (CL:PUSH FILE-INSTANCES MULTIPLE-INSTANCES)))
                            (DESTRUCTURING-BIND (NAME CRDATE)
                                   (CAR FILE-INSTANCES)
                                   (PRINTOUT T "Copying " NAME " to " (PACKFILENAME 'DIRECTORY 
                                                                             TEST-DIR 'BODY FILE-NAME
                                                                             )
                                          "...")
                                   (COPYFILE NAME (PACKFILENAME 'DIRECTORY TEST-DIR 'BODY FILE-NAME))
                                   (PRINTOUT T "Done." T)))))))
)



(* |;;| "Record success and failure in AR Test-Case runs")


(DEFCOMMAND "Pass" (&REST AR-NUMBERS)
   "Log successful AR Test-case runs for the AR numbers given."
   (FOR AR IN AR-NUMBERS DO (\\RECORD-AR-TEST-CASE-SUCCESS AR T)))

(DEFCOMMAND "Fail" (&REST AR-NUMBERS)
   "Log UN-successful AR Test-case runs for the AR numbers given."
   (FOR AR IN AR-NUMBERS DO (\\RECORD-AR-TEST-CASE-SUCCESS AR NIL)))

(CL:DEFUN \\RECORD-AR-TEST-CASE-SUCCESS (AR-NUMBER PASSED?)

   (* |;;| "Record whether the Test case for AR-NUMBER ran OK or not.  If PASSED? is non-NIL, the test case ran OK.")

   (* |;;| "--Used by the \"Pass\" and \"Fail\" commands--")

   (COND
      ((NUMBERP AR-NUMBER)

       (* |;;| "It was a number. so log it.")

       (LET ((*READTABLE* FILERDTBL))
            (CL:WITH-OPEN-STREAM (LOG (OPENSTREAM *AR-TEST-CASE-LOG-FILE* 'APPEND 'OLD))
                   (PRINT (LIST AR-NUMBER (COND
                                             (PASSED? (CL:FORMAT T "Recording success for AR ~d." 
                                                             AR-NUMBER)
                                                    :PASS)
                                             (T (CL:FORMAT T "Recording failure for AR ~d." AR-NUMBER
                                                       )
                                                :FAIL))
                                (USERNAME)
                                (DATE))
                          LOG))))
      (T 
         (* |;;| "That wasn't an AR number.  Complain about it.")

         (CL:WARN "Not an AR Number:  ~A~%" AR-NUMBER))))

(RPAQ *AR-TEST-CASE-LOG-FILE* "{ERIS}<Test>ARs>AR-TEST-CASE.Auto-log")

(RPAQ *AR-TEST-CASE-SUMMARY-TEMPLATE-FILE* "{ERIS}<Test>ARs>AR-Test-Case-Summary-Template.TEdit")



(* |;;| "Report generation functions")


(CL:DEFUN AR-TEST-CASE-SUMMARY (&OPTIONAL PRINT-FILE)

   (* |;;| "Creates a summary showing AR Test-Case status by AR# for all AR test cases ever run.")

   (LET (LOWEST-SEEN-AR HIGHEST-SEEN-AR AR-TABLE LOG-ENTRY REPORT-FORM)
        (CL:MULTIPLE-VALUE-SETQ (LOWEST-SEEN-AR HIGHEST-SEEN-AR AR-TABLE)
               (AR-TEST-CASE-READ 5))
        (CL:WITH-OPEN-STREAM (REPORT (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW))
               (FOR AR# FROM LOWEST-SEEN-AR TO HIGHEST-SEEN-AR
                  DO (SETQ LOG-ENTRY (CL:AREF AR-TABLE AR#))
                        (COND
                           (LOG-ENTRY                        (* \; "The test got run sometime.")
                                  (DESTRUCTURING-BIND (AR# PASS/FAIL TESTER TIME-STAMP)
                                         LOG-ENTRY
                                         (PRINTOUT REPORT AR# "	" (SELECTQ PASS/FAIL
                                                                      (:PASS "OK")
                                                                      (:FAIL "-BAD-")
                                                                      "??")
                                                T)))
                           (T                                (* \; "The test never got run.")
                              (PRINTOUT REPORT AR# "	--" T))))
               (FORCEOUTPUT REPORT T)
               (SETQ REPORT-FORM (OPENTEXTSTREAM (MKATOM *AR-TEST-CASE-SUMMARY-TEMPLATE-FILE*)
                                        NIL NIL NIL '(SEL 1)))
               (TEDIT.NEXT REPORT-FORM)
               (TEDIT.INSERT REPORT-FORM (DATE))
               (TEDIT.NEXT REPORT-FORM)
               (TEDIT.DELETE REPORT-FORM)
               (TEDIT.RAW.INCLUDE REPORT-FORM REPORT)
               (TEDIT.HARDCOPY REPORT-FORM PRINT-FILE)
               (CLOSEF REPORT-FORM))))

(CL:DEFUN AR-TEST-CASE-READ (&OPTIONAL (MINIMUM-INTERESTING-AR-NUMBER 5))

   (* |;;| "Read the most recent results for every AR test case ever run into an array.  Returns the 3 values, \"lowest AR number seen\", \"highest AR number seen\", and the array of results.")

   (LET ((LOWEST-SEEN-AR 65535)
         (HIGHEST-SEEN-AR 0)
         (AR-TABLE (CL:MAKE-ARRAY 32000)))
        (CL:WITH-OPEN-STREAM (LOG (OPENSTREAM *AR-TEST-CASE-LOG-FILE* 'INPUT 'OLD))
               (WHILE (SETQ LOG-ENTRY (CL:READ LOG NIL NIL))
                  DO (DESTRUCTURING-BIND (AR# PASS/FAIL TESTER TIME-STAMP)
                                LOG-ENTRY
                                (COND
                                   ((AND (NUMBERP AR#)
                                         (> AR# MINIMUM-INTERESTING-AR-NUMBER))
                                    (SETQ HIGHEST-SEEN-AR (IMAX HIGHEST-SEEN-AR AR#))
                                    (SETQ LOWEST-SEEN-AR (IMIN LOWEST-SEEN-AR AR#))
                                    (ASET LOG-ENTRY AR-TABLE AR#))))))
        (CL:VALUES LOWEST-SEEN-AR HIGHEST-SEEN-AR AR-TABLE)))

(CL:DEFUN AR-FAILING-TEST-CASES (&OPTIONAL PRINT-FILE)

   (* |;;| "Collect a list of the AR test cases that have run but have failed.")

   (LET (LOWEST-SEEN-AR HIGHEST-SEEN-AR AR-TABLE LOG-ENTRY REPORT-FORM)
        (CL:MULTIPLE-VALUE-SETQ (LOWEST-SEEN-AR HIGHEST-SEEN-AR AR-TABLE)
               (AR-TEST-CASE-READ 5))
        (FOR AR# FROM LOWEST-SEEN-AR TO HIGHEST-SEEN-AR
           WHEN (SETQ LOG-ENTRY (DESTRUCTURING-BIND (AR# PASS/FAIL TESTER TIME-STAMP)
                                           (CL:AREF AR-TABLE AR#)
                                           (EQ PASS/FAIL :FAIL))) COLLECT AR#)))



(* |;;| "Patch-file creation support.")




(* |;;| "See {Eris}<Lispcore>Internal>Doc>Making-a-Patch.TEdit for details.")


(DEFCOMMAND "PATCH" (&REST ARS)
   (\\MAKE-PATCH-FILE ARS))

(DEFCOMMAND "LIBPATCH" (&REST ARS)

   (* |;;| "Given a list of ARs on the command line, ask for the Library file name(s) of the files that patch it; move those files to the patch directory; log the patch.")

   (LET (FILE-LINE FILES COMPILED-FILES FOUND-FILES)
        (SETQ FILE-LINE (PROMPTFORWORD 
                               "Library File(s) that make up the patch (spaces between names):  " NIL
                               NIL NIL NIL NIL (CHARCODE (CR LF))))
        (SETQ FILES (CL:WITH-INPUT-FROM-STRING (LINE FILE-LINE)
                           (WHILE (NOT (EOFP LINE)) COLLECT (PROG1 (RATOM LINE)
                                                                        (OR (EOFP LINE)
                                                                            (SKIPSEPRS LINE))))))
        (SETQ FOUND-FILES (FOR FILE IN FILES COLLECT (OR (FINDFILE FILE NIL '(
                                                                             {ERIS}<LISPCORE>LIBRARY>
                                                                                          ))
                                                                     (HELP 
                                                                  "File not found in the patch list."
                                                                           ))))
        (SETQ COMPILED-FILES (FOR FILE IN FILES COLLECT (FINDFILE-WITH-EXTENSIONS
                                                                     FILE
                                                                     '({ERIS}<LISPCORE>LIBRARY>)
                                                                     '(DFASL LCOM))))
        (COPYFILES FOUND-FILES "{ERIS}<LISPCORE>PATCHES>LIBRARY>")
        (COPYFILES COMPILED-FILES "{ERIS}<LISPCORE>PATCHES>LIBRARY>")
        (\\LOG-A-PATCH ARS FILES)))

(DEFCOMMAND "LOGPATCH" (ARS FILES)

   (* |;;| "Given a list of ARs on the command line, ask for the Library file name(s) of the files that patch it; move those files to the patch directory; log the patch.")

   (LET NIL (COND
               ((AND (LISTP ARS)
                     (LISTP FILES))
                (\\LOG-A-PATCH ARS FILES))
               (T (PRINTOUT T "ARs or FILEs weren't a list.")))))
(DEFINEQ

(\\MAKE-PATCH-FILE
  (LAMBDA (AR-LIST)                                      (* \; "Edited  8-Nov-88 19:16 by jds")
    (LET* ((MAIN-AR (CAR AR-LIST))
           (FILE-NAME (CL:FORMAT NIL "AR~{-~A~}-PATCH" AR-LIST))
           (COMSNAME (PACK* FILE-NAME 'COMS))
           (AR-FEATURE-LIST (|for| AR |in| AR-LIST |collect| (CL:INTERN (CONCAT "AR-" AR)
                                                                                "KEYWORD"))))
          (SET COMSNAME (COPYALL `(                          (* |;;| (\\\, (CL:FORMAT NIL 
                                                 "Patch file ~A.  Contains fixes for the AR(s) ~S."
                                 FILE-NAME AR-LIST)))
                                   (ADDVARS (*FEATURES* ,@AR-FEATURE-LIST))
                                   (FILES "Pre-requisite patches")
                                   (FNS)
                                   (VARS))))                 (* \; "Build fileCOMS")
          (ED (MKATOM FILE-NAME)
              :FILES)                                        (* \; 
                    "Edit the file, so user can fill in functions, etc., to be saved in the patch.")

          (* |;;| "Log the patch:")

          (\\LOG-A-PATCH AR-LIST (LIST (MKATOM FILE-NAME))))))

(\\LOG-A-PATCH
  (LAMBDA (AR-LIST FILE-LIST)                            (* \; "Edited 14-Oct-88 14:21 by jds")

    (* |;;| "Write the log entries for a patch, setting for each AR patches the name of the patch file(s).  Send a message to Cheryl and John saying that it got patched.")

    (LET* ((PATCH-NOTIFY-LIST (SELECTQ (LAFITEMODE)
                                  (GV "James.envos, Sybalsky.envos")
                                  (NS "James:AISNorth, Sybalsky:AISNorth")
                                  (ERROR "LAFITEMODE not set.")))
           MSG)
          (LET ((*READTABLE* FILERDTBL))
               (CL:WITH-OPEN-STREAM (LOG (OPENSTREAM "{ERIS}<Lispcore>Patches>Patch-Directory"
                                                'APPEND
                                                'OLD))
                      (|for| AR |in| AR-LIST |do| (PRINT (LIST AR FILE-LIST (USERNAME)
                                                                           (DATE))
                                                                     LOG))))
          (SETQ MSG (OPENTEXTSTREAM (CONCAT (CL:FORMAT NIL 
                                          "Subject: Patches Created for AR~p~{ ~A~#[.~;, and~:;,~]~}"
                                                   (FLENGTH AR-LIST)
                                                   AR-LIST)
                                           "
To: " PATCH-NOTIFY-LIST "
cc: " (FULLUSERNAME)
                                           (CL:FORMAT NIL "~%~%Patch Files:~{~14T~A~%~}" FILE-LIST))
                           NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT)))
          (ADD.PROCESS `(\\SENDMESSAGE ',MSG 'NAME 'MESSAGESENDER)))))
)

(PUTPROPS RELEASETOOLS FILETYPE CL:COMPILE-FILE)
(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(PUTPROPS RELEASETOOLS COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (5358 20490 (COMPDIR 5368 . 13248) (FLOPPYDIR 13250 . 13838) (FLOPPYDIRECTORY 13840 . 
15612) (FLOPPYINDEX 15614 . 18276) (FLOPPYINDEXAUX 18278 . 20488)) (20729 29891 (LIBTOOL.MAKE.FLOPPIES
 20739 . 21629) (LIBTOOL.REQUEST.FLOPPY 21631 . 22096) (LIBTOOL.MAKE.FLOPPIES.AUX 22098 . 24399) (
LIBTOOL.BREAK.DEPENDENCY 24401 . 25444) (LIBTOOL.FIND.FREE.FLOPPY 25446 . 26509) (LIBTOOL.WRITE.FILES 
26511 . 27480) (LIBTOOL.CONFIRM.BREAK 27482 . 28790) (LIBTOOL.INITIALIZE.FLOPPY 28792 . 29889)) (30174
 40268 (DATECOMP 30184 . 36959) (COMPCRDA 36961 . 38329) (BOTHHAVE 38331 . 38905) (PRINT2LISTS 38907
 . 40266)) (40436 44560 (WHATVER 40446 . 44558)) (44665 45780 (SELECT-NEWER-FILES 44675 . 45778)) (
47752 49970 (VERIFY-FLOPPIES 47762 . 49968)) (50058 53124 (CONSOLIDATED-DIRECTORIES 50068 . 51853) (
CONSOLIDATED-DIRECTORY-LISTING 51855 . 53122)) (53232 54749 (MOVE-TESTS 53242 . 54747)) (62812 65853 (
\\MAKE-PATCH-FILE 62822 . 64139) (\\LOG-A-PATCH 64141 . 65851)))))
STOP
\ No newline at end of file
diff --git a/internal/library/SMART-TRICKLE b/internal/library/SMART-TRICKLE
new file mode 100644
index 00000000..d2d7c1a5
Binary files /dev/null and b/internal/library/SMART-TRICKLE differ
diff --git a/internal/library/SPLICE b/internal/library/SPLICE
new file mode 100644
index 00000000..dab07311
--- /dev/null
+++ b/internal/library/SPLICE
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "26-Jun-90 19:24:01" {DSK}<usr>local>lde>lispcore>internal>library>SPLICE.;2 3583   

      changes to%:  (VARS SPLICECOMS)

      previous date%: "22-Nov-84 16:35:38" {DSK}<usr>local>lde>lispcore>internal>library>SPLICE.;1)


(* ; "
Copyright (c) 1990 by Venue & Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT SPLICECOMS)

(RPAQQ SPLICECOMS ((FNS * SPLICEFNS)
                       (VARS BYTESPERPAGE)))

(RPAQQ SPLICEFNS (CLIP JJOIN LSPLICE NCLIP NSPLICE SPLICE SPLICEJ SPLICES))
(DEFINEQ

(CLIP
  [LAMBDA (SRCFIL DSTFIL)                                (* bvm%: "24-Sep-84 15:03")
    (CLOSEALL)
    [COPYBYTES (OPENFILE SRCFIL 'INPUT)
           (OPENFILE DSTFIL 'BOTH 'OLD NIL '(DON'T.CHANGE.DATE]
    (CLOSEALL])

(JJOIN
  [LAMBDA (SRCFIL DSTFIL)                                (* scp " 6-DEC-82 15:43")
    (CLOSEALL)
    (COPYBYTES (OPENFILE SRCFIL 'INPUT)
           (OPENFILE DSTFIL 'APPEND 'OLD))
    (CLOSEALL])

(LSPLICE
  [LAMBDA NIL                                            (* scp "14-DEC-82 22:30")
    (CLIP '{DSK}DLISPDOMINO.DB '{DSK}LISP.DLBOOT])

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

(NSPLICE
  [LAMBDA (DLBOOTNAME)                                   (* edited%: " 6-APR-83 15:34")
    (NCLIP '{DSK}DLISPDOMINO.DB (OR DLBOOTNAME '{DSK}BIGTEST.DLBOOT])

(SPLICE
  [LAMBDA (DLBOOTNAME)                                   (* scp "14-JAN-83 11:42")
    (CLIP '{DSK}DLISPDOMINO.DB (OR DLBOOTNAME '{DSK}BIGTEST.DLBOOT])

(SPLICEJ
  [LAMBDA NIL                                            (* scp " 6-DEC-82 15:45")
    (JOIN '{DSK}TEST.SYSOUT '{DSK}TEST.DLBOOT])

(SPLICES
  [LAMBDA NIL                                            (* JonL "22-NOV-82 17:29")
    (PROG NIL
      LP  (SPLICE)
          (LOGOUT)
          (GO LP])
)

(RPAQQ BYTESPERPAGE 512)
(PUTPROPS SPLICE COPYRIGHT ("Venue & Xerox Corporation" 1990))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (587 3467 (CLIP 597 . 834) (JJOIN 836 . 1051) (LSPLICE 1053 . 1211) (NCLIP 1213 . 2766) 
(NSPLICE 2768 . 2950) (SPLICE 2952 . 3127) (SPLICEJ 3129 . 3284) (SPLICES 3286 . 3465)))))
STOP
\ No newline at end of file
diff --git a/internal/library/TAR b/internal/library/TAR
new file mode 100644
index 00000000..08623faf
--- /dev/null
+++ b/internal/library/TAR
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "26-Jun-90 19:28:14" |{DSK}<usr>local>lde>lispcore>internal>library>TAR.;2| 3663   

      |changes| |to:|  (VARS TARCOMS)

      |previous| |date:| "31-Dec-00 17:55:22" |{DSK}<usr>local>lde>lispcore>internal>library>TAR.;1|
)


; Copyright (c) 1987, 1900, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT TARCOMS)

(RPAQQ TARCOMS ((RECORDS TARHEADER)
                    (FNS GATHER-NAME READ-TAR-FILE)))
(DECLARE\: EVAL@COMPILE

(BLOCKRECORD TARHEADER ((FILENAME BYTE 100)
                            (MODE BYTE 8)
                            (UID BYTE 8)
                            (GID BYTE 8)
                            (SIZE BYTE 12)
                            (MTIME BYTE 12)
                            (CHKSUM BYTE 8)
                            (LINKFLAG BYTE)
                            (LINKNAME BYTE 100)))
)
(DEFINEQ

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

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

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

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

           (SETFILEPTR INSTREAM (OR START 0))
           (|while| (NOT (EOFP INSTREAM))
              |do| (\\BINS INSTREAM BUFFER 0 512)
                   (SETQ FILENAME (GATHER-NAME BUFFER 2))
                   (SETQ SIZE (CL:WITH-INPUT-FROM-STRING (IN SIZE-STRING)
                                     (LET ((*READTABLE* (FIND-READTABLE "XCL"))
                                           (*READ-BASE* 8))
                                          (CL:READ IN))))
                   (PRINTOUT T "FILE:  " FILENAME ",  SIZE = " SIZE T)
                   (COND
                      ((AND (NOT LIST-ONLY)
                            (> SIZE 0))
                       (SETQ OLDFPTR (GETFILEPTR INSTREAM))
                       (COND
                          ((OR (NOT SKIP-EXISTING-FILES)
                               (NOT (CL:PROBE-FILE FILENAME)))
                           (CL:WITH-OPEN-STREAM (OUT (OPENSTREAM FILENAME 'OUTPUT 'NEW
                                                            `((SEQUENTIAL T)
                                                              (BUFFERS 40)
                                                              (LENGTH ,SIZE))))
                                  (COPYBYTES INSTREAM OUT SIZE))))
                       (SETFILEPTR INSTREAM (+ OLDFPTR (ITIMES 512 (IQUOTIENT (+ SIZE 511)
                                                                          512)))))))))))
)
(PUTPROPS TAR COPYRIGHT ("Venue & Xerox Corporation" 1987 1900 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (944 3570 (GATHER-NAME 954 . 1560) (READ-TAR-FILE 1562 . 3568)))))
STOP
\ No newline at end of file
diff --git a/internal/library/TYPEHAX b/internal/library/TYPEHAX
new file mode 100644
index 00000000..9c65c207
--- /dev/null
+++ b/internal/library/TYPEHAX
@@ -0,0 +1 @@
+(FILECREATED "30-Sep-86 18:49:53" {ERIS}<LISPCORE>INTERNAL>TYPEHAX.;4 3701   

      changes to:  (VARS TYPEHAXCOMS)
                   (FUNCTIONS COLLECT-SUPER-CHAIN TEST-TYPEP ALLOCATE-WITH-NAME ALLOCATE-SUPER-CHAIN 
                          ALLOCATE-11-BIT-TYPES ALLOCATE-TO-TYPE-NUMBER)

      previous date: "30-Sep-86 15:05:33" {ERIS}<LISPCORE>INTERNAL>TYPEHAX.;1)


(PRETTYCOMPRINT TYPEHAXCOMS)

(RPAQQ TYPEHAXCOMS ((FUNCTIONS ALLOCATE-11-BIT-TYPES ALLOCATE-SUPER-CHAIN ALLOCATE-TO-TYPE-NUMBER 
                           ALLOCATE-WITH-NAME COLLECT-SUPER-CHAIN TEST-TYPEP)))
(DEFUN ALLOCATE-11-BIT-TYPES NIL (ALLOCATE-TO-TYPENUMBER 1023)
                                                  (* ;;; 
      "allocates typenumber 1023, then allocates a type named %"realbig%", and checks it's instances")
                                 (ALLOCATE-WITH-NAME (QUOTE REALBIG))
                                 (CL:SETQ AREALBIG (NCREATE (QUOTE REALBIG)))
                                 (TYPENAMEP AREALBIG (QUOTE REALBIG))
                                 (EQ (NTYPX AREALBIG)
                                     1024))

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

(DEFUN ALLOCATE-TO-TYPE-NUMBER (X)                (* ;;; 
                                                  "Allocates datatypes up to datatype x inclusive.")
   (LET ((REMAINING (- X \MaxTypeNumber)))
        (CL:IF (< REMAINING 1)
               (CL:ERROR "There are already ~D datatypes." \MaxTypeNumber)
               (PROGN (DECLAREDATATYPE (QUOTE TEST-SUPER)
                             (QUOTE (POINTER))
                             NIL NIL)             (* ;; "declare a super for the rest of the types.")
                      (DOTIMES (I REMAINING)
                             (DECLAREDATATYPE (GENSYM (QUOTE TEST))
                                    (QUOTE (POINTER))
                                    NIL NIL (QUOTE TEST-SUPER)))))))

(DEFUN ALLOCATE-WITH-NAME (TYPENAME &OPTIONAL (SUPER (QUOTE TEST-SUPER)))
   (ETYPECASE TYPENAME (SYMBOL (DECLAREDATATYPE TYPENAME (QUOTE (POINTER))
                                      NIL NIL SUPER))))

(DEFUN COLLECT-SUPER-CHAIN (ROOT) (CL:DO* ((TYPE ROOT SUPER)
                                           (SUPER (GETSUPERTYPE TYPE)
                                                  (GETSUPERTYPE TYPE))
                                           (SUPER-CHAIN NIL))
                                         ((NULL SUPER)
                                          SUPER-CHAIN)
                                         (CL:PUSH SUPER SUPER-CHAIN)))

(DEFUN TEST-TYPEP (TYPE)                          (* ;;; 
                                "ensures that instances of TYPE are instances of all its supertypes.")
   (LET ((INSTANCE (NCREATE TYPE)))
        (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (TYPE)
                                       (TYPEP INSTANCE TYPE)))
               (COLLECT-SUPER-CHAIN TYPE))))

(DECLARE: DONTCOPY
  (FILEMAP (NIL)))
STOP
\ No newline at end of file
diff --git a/internal/library/WHEREIS b/internal/library/WHEREIS
new file mode 100644
index 00000000..42fab331
--- /dev/null
+++ b/internal/library/WHEREIS
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "26-Jun-90 19:35:02" |{DSK}<usr>local>lde>lispcore>internal>library>WHEREIS.;2| 21991  

      |changes| |to:|  (VARS WHEREISCOMS)

      |previous| |date:| "29-Oct-86 13:17:33" 
|{DSK}<usr>local>lde>lispcore>internal>library>WHEREIS.;1|)


; Copyright (c) 1983, 1984, 1986, 1990 by Venue & Xerox Corporation.  All rights reserved.

(PRETTYCOMPRINT WHEREISCOMS)

(RPAQQ WHEREISCOMS
       (                                                     (* \; "WHEREIS from a hashfile")
        (FILES HASH)
        (FNS HASHFILE-WHEREIS CLOSEWHEREIS WHEREISNOTICE WHEREISNOTICE1)
        (ADDVARS (WHEREIS.HASH))
        (GLOBALVARS WHEREIS.HASH)
        (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD 'HASHFILE-WHEREIS 'WHEREIS))
               (ADDVARS (AROUNDEXITFNS CLOSEWHEREIS)))
        (COMS                                                (* \; 
                               "Possibly obsolete now that directory enumerates highest version ok")
              (FNS \\REMOVEOLDVERSIONS))
        (LOCALVARS . T)))



(* \; "WHEREIS from a hashfile")


(FILESLOAD HASH)
(DEFINEQ

(hashfile-whereis
  (lambda (name type files fn)                               (* |bvm:| "28-Apr-86 12:24")
    (prog (val)
          
          (* |if| fn |given,| apply* |to| |each| |element| |and| |return| nil)

          (cond
             ((eq name t)
          
          (* t |as| \a name |has| \a |special| |meaning| |to| infilecoms? |so| |don't| 
          |pass| |through.|)

              (return nil)))
          (setq type (getfilepkgtype type))
          (|for| file |in| (or (listp files)
                               filelst)
                 |do|
                 (cond
                    ((infilecoms? name type (filecoms file))
                     (cond
                        (fn (apply* fn name file)))
                     (setq val (cons file val)))))
          (and
           (eq files t)
           (eq type 'fns)
           (litatom name)
           (progn (cond
                     ((and whereis.hash (nlistp whereis.hash))
                                                             (* |make| |sure| whereis.hash |is| \a 
                                                             |list.|)
                      (setq whereis.hash (list whereis.hash))))
                  (|for| whishsfile hname hsfile delp |on| whereis.hash |do| 
          
          (* whereis.hash |is| \a |list| |of| |hash| |file| |names| |off| |of| |which| 
          |the| |hash| |file| |structure| |is| |linked| |into| |the| |system| |hash| 
          |array.| |The| |full| |file| |name| |is| |hashed.|)

                         (cond
                            ((listp (setq hname (car whishsfile)))
                                                             (* |file| |already| |has| |an| 
                                                             |associated| |hashfile| |datatype|)
                             (setq hsfile (cdr hname)))
                            ((setq hsfile (findfile hname t))
                             (cond
                                ((|find| x |in| whereis.hash |suchthat|
                                        (and (listp x)
                                             (eq hsfile (hashfileprop (cdr x)
                                                               'name))))
                                                             (* |Looks| |like| \a |duplicate| 
                                                             |entry|)
                                 (rplaca whishsfile (setq hsfile nil))
                                 (setq delp t))
                                (t (setq hsfile (openhashfile hsfile))
          
          (* |if| |the| |data| |file| |is| |ever| |closed,| |break| |the| |link| |to| 
          |the| |hash| |file| |structure.|)

                                   (whenclose (hashfileprop hsfile 'stream)
                                          'before
                                          (function (lambda (strm)
                                                      (|for| tail |on| whereis.hash |when|
                                                             (and (listp (car tail))
                                                                  (eq strm (hashfileprop (cdar tail)
                                                                                  'stream)))
                                                             |do|
          
          (* |remove| |the| |hashfile| |structure| |for| |this| |file's| |entry| |on| 
          whereis.hash.)

                                                             (rplaca tail (caar tail)))))
                                          'closeall
                                          'no)
                                   (rplaca whishsfile (cons hname hsfile)))))
                            (t (or (eq 'y (askuser 120 'y (concat hname 
                         ", a file on WHEREIS.HASH, not found -- do you want to delete and continue?"
                                                                 )
                                                 '((y "es")
                                                   (n "o"))))
                                   (errorx (list 23 hname)))
                               (rplaca whishsfile (setq hsfile nil))
                               (setq delp t)))
                         (cond
                            (hsfile (|for| file |inside| (gethashfile name hsfile)
                                           |when|
                                           (not (fmemb file val))
                                           |do|
                                           (and fn (apply* fn name file))
                                           (|push| val file))))
                         |finally|
                         (cond
                            (delp (setq whereis.hash (dremove nil whereis.hash)))))))
          (return (and (null fn)
                       (dreverse val))))))

(closewhereis
  (lambda (flg)                                              (* |bvm:| "28-Apr-86 12:33")
          
          (* * |Close| |the| |whereis| |file| |over| |logout,| |since| |there's| |no| 
          |point| |in| |paying| |to| |keep| |it| |open|)

    (and whereis.hash (selectq flg
                          ((nil beforelogout beforesysout beforemakesys) 
                               (|for| hf |in| (|for| wh |in| whereis.hash |when| (listp wh)
                                                     |collect|
                                                             (* |Gather| |the| |hashfile| |handles|)
                                                     (cdr wh))
                                      |do|
                                      (nlsetq (closehashfile hf))))
                          nil))))

(whereisnotice
  (lambda (filegroups newflg databasefile scratchdir compute.highest.versions.manually)
                                                             (* |bvm:| " 5-Oct-86 16:36")
                                                  (* |;;| "Copies the current whereis hash-file into a scratch file, then notices the files in FILEGROUP The copy is so that this function will execute even though someone else is reading the current database.  The database is copied to a scratch file, then renamed to be a newer version of the previous database, which is deleted.  This allows others to use the old database while the copying is going on.  If an earlier version of the scratch file exists, it means that someone else is currently updating (their version disappears when they complete successfully or logout), so we wait for them to finish.")
                                                  (* |;;| "COMPUTE.HIGHEST.VERSIONS.MANUALLY means don't trust DIRECTORY to get the highest version of a file only when enumerating.")
    (resetlst (prog ((databasefilename (or databasefile (|if| whereis.hash |then| 
                                                  (* \; 
                                                  "if there is a list of files, use the top one.")
                                                              (|if| (nlistp whereis.hash)
                                                                    |then| whereis.hash |elseif|
                                                                    (nlistp (car whereis.hash))
                                                                    |then|
                                                                    (car whereis.hash)
                                                                    |else|
                                                                    (caar whereis.hash))
                                                              |else|
                                                              'whereis.hash)))
                     (scratchval (list nil))
                     hf scratch oldwh)
                    (setq oldwh (infilep databasefilename))  (* \; "creates a scratch file")
                    (|if| (and oldwh (not newflg))
                          |then|                             (* \; "copy old one")
                          (resetsave nil (list (function (lambda (x)
                                                           (|if| (car x)
                                                                 |then|
                                                                 (closef? (car x))
                                                                 (and resetstate (delfile
                                                                                  (car x))))))
                                               scratchval))
                          (rplaca scratchval (setq hf (closef (openfile (setq scratch
                                                                         (packfilename
                                                                          'directory
                                                                          (filenamefield 
                                                                                 databasefilename
                                                                                 'directory)
                                                                          'name
                                                                          'newwhereisdatabase
                                                                          'extension
                                                                          'scratch
                                                                          'temporary
                                                                          's))
                                                                     'output
                                                                     'new))))
                                                  (* \; 
                     "Compensate for the fact that PACKFILENAME produces version -1 for temporary ;S")
                          (and (eq (systemtype)
                                   'tops20)
                               (setq scratch (packfilename 'version nil 'body scratch)))
                                                  (* |;;| "If there is a version earlier than the one we got, someone else must have it, and we must wait until he gets rid of it (by deleting it)")
                          (|bind| oldv (rpt _ 1)
                                 |until|
                                 (eq hf (setq oldv (fullname scratch 'oldest)))
                                 |do|
                                 (dismiss 2000)
                                 (or (null rpt)
                                     (|if| (eq rpt 5)
                                           |then|
                                           (|printout| t t (getfileinfo oldv 'author)
                                                  " seems to be updating the database right now." t 
                                                  "I'm waiting for him to finish." t t)
                                           (setq rpt nil)
                                           |else|
                                           (|add| rpt 1))))
                          (setq hf (copyhashfile oldwh hf nil nil t))
                          (closef? oldwh)
                          |elseif|
                          (and oldwh (eq newflg 'nocopy))
                          |then|
                          (setq hf (openhashfile oldwh 'both nil))
                          (setq scratchdir nil)
                          |else|
                          (resetsave nil (list (function (lambda (x)
                                                           (|if| (car x)
                                                                 |then|
                                                                 (setq x (closehashfile (car x)))
                                                                 (and resetstate (delfile x)))))
                                               scratchval))
                          (rplaca scratchval (setq hf (createhashfile
                                                       (|if| scratchdir |then| (packfilename.string
                                                                                'directory scratchdir
                                                                                'body 
                                                                                databasefilename)
                                                             |else| databasefilename)
                                                       'smallexpr nil (or (numberp newflg)
                                                                          20000))))
                          (setq newflg t))        (* |;;| "Must leave the new file open--otherwise, the user might lose access to it before he starts to do the noticing.")
                    (|for| x |in| (|for| filespec |inside| filegroups |bind| tem |join|
                                         (|if| (setq tem (infilep filespec))
                                               |then|        (* \; "an individual file")
                                               (list tem)
                                               |else|
                                                  (* |;;| "a specification for a group of files, expand it.  Default to *.; -- i.e., highest version only of the extensionless files on this dir.")
                                               (setq tem (directory (packfilename.string 'body 
                                                                           filespec 'name "*"
                                                                           'extension "" 'version "")
                                                                ))
                                               (|if| compute.highest.versions.manually |then|
                                                     (\\removeoldversions tem)
                                                     |else| tem)))
                           |do|
                           (ersetq (|printout| t (whereisnotice1 x hf)
                                          -2)))
                    (setq hf (closehashfile hf))
                    (rplaca scratchval nil)       (* |;;| "This closes the file, but other updaters are still locked out cause they go for a new version and then trip over our old one.")
                    (cond
                       ((not newflg)
                        (|if| (setq hf (renamefile hf (packfilename 'version nil 'body 
                                                             databasefilename)))
                              |then|
                              (delfile oldwh)))
                       (scratchdir (setq hf (renamefile hf databasefilename))))
                                                   (* \; "Now others can get in to read or update.")
                    (return hf)))))

(whereisnotice1
  (lambda (file hf tryhard)                                  (* |bvm:| " 5-Oct-86 16:08")
    (resetlst (prog (name map date val env stream)
                    (resetsave nil (list 'closef (setq stream (openstream file 'input 'old nil
                                                                     '(don\'t.change.read.date 
                                                                             don\'t.change.date)))))
                    (setq file (fullname stream))
                    (setfileptr stream 0)
                    (cl:multiple-value-setq (env map)
                           (get-environment-and-filemap stream t))
                    (or map (return (list file "--can't find filemap")))
                    (|if| (and (not tryhard)
                               (equal (setq date (filedate stream))
                                      (gethashfile file hf))
                               date)
                          |then|                             (* \; " already analyzed")
                          (return (list file date)))
                    (setq name (namefield file t))
                    (|for| x |in| (cdr map)
                           |do|
                           (|for| y |in| (cddr x)
                                  |unless|
                                  (or (null (setq val (lookuphashfile (car y)
                                                             name hf '(insert retrieve))))
                                      (eq name val)
                                      (and (listp val)
                                           (fmemb name val)))
                                  |do|            (* |;;| "the first LOOKUPHASHFILE stores NAME as value if there was no previous value, else returns previous value.  If that value was non-null and did not contain NAME, now have to store union of NAME and what was there.")
                                  (puthashfile (car y)
                                         (nconc1 (or (listp val)
                                                     (list val))
                                                name)
                                         hf)))
                    (puthashfile file date hf)
                    (return file)))))
)

(ADDTOVAR WHEREIS.HASH )
(DECLARE\: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS WHEREIS.HASH)
)
(DECLARE\: DONTEVAL@LOAD DOCOPY 

(MOVD 'HASHFILE-WHEREIS 'WHEREIS)


(ADDTOVAR AROUNDEXITFNS CLOSEWHEREIS)
)



(* \; "Possibly obsolete now that directory enumerates highest version ok")

(DEFINEQ

(\\removeoldversions
  (lambda (fullfilelst)                                      (* |rrb| "22-Feb-84 18:12")
          
          (* |removes| |all| |but| |the| |newest| |version| |of| |any| |file| |on| 
          fullfilelst. |Slow| |version| |as| |temporary| |until| directory |has| \a |way| 
          |of| |asking| |for| |only| |the| |most| |recent| |version.|)

    (prog ((expandedfilelst (|for| file |in| fullfilelst |collect| (unpackfilename file)))
           uniquelst file)
          (|for| exptail |on| expandedfilelst |do|           (* |skip| |deleted| |files.|)
                 (and (setq file (car exptail))
                      (prog ((xdirectory (listget file 'directory))
                             (xname (listget file 'name))
                             (xextension (listget file 'extension))
                             (xversion (listget file 'version)))
          
          (* |go| |thru| |the| |list| |of| |expanded| |files| |and| |see| |if| |there| 
          |are| |any| |other| |files| |on| |the| |list| |with| |the| |same| |name.|
          i\f |so| |and| |it| |is| |older,| |delete| |it.|
          i\f |so| |and| |it| |is| |newer,| |don't| |copy| |this| |guy| |onto| |the| 
          |result| |list.|)

                            (|for| efltail |on| (cdr exptail)
                                   |do|
                                   (setq file (car efltail))
                                   (cond
                                      ((and (eq (listget file 'name)
                                                xname)
                                            (eq (listget file 'extension)
                                                xextension)
                                            (eq (listget file 'directory)
                                                xdirectory))
                                       (cond
                                          ((igreaterp (listget file 'version)
                                                  xversion)  (* xfile |should| |be| |deleted|)
                                           (return nil))
                                          (t 
          
          (* |mark| |it| |deleted.| |Don't| |want| |to| |play| |around| |with| |the| 
          |pointers| |because| |the| |enclosing| for |is| |using| |the| |same| |list.|)

                                             (rplaca efltail nil)))))
                                   |finally|
                                   (setq uniquelst (cons (car exptail)
                                                         uniquelst))))))
          (return (|for| ufile |in| uniquelst |collect| (packfilename ufile))))))
)
(DECLARE\: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(PUTPROPS WHEREIS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1986 1990))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (1157 18785 (HASHFILE-WHEREIS 1167 . 6182) (CLOSEWHEREIS 6184 . 7040) (WHEREISNOTICE 
7042 . 16464) (WHEREISNOTICE1 16466 . 18783)) (19078 21835 (\\REMOVEOLDVERSIONS 19088 . 21833)))))
STOP
\ No newline at end of file
diff --git a/internal/library/WHEREIS.TEDIT b/internal/library/WHEREIS.TEDIT
new file mode 100644
index 00000000..90c19f44
Binary files /dev/null and b/internal/library/WHEREIS.TEDIT differ
diff --git a/internal/library/XCLC-DEBUG b/internal/library/XCLC-DEBUG
new file mode 100644
index 00000000..2113e9c7
--- /dev/null
+++ b/internal/library/XCLC-DEBUG
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "COMPILER")
(il:filecreated "21-Sep-88 12:35:01" il:{eris}<lispcore>internal>library>xclc-debug.\;2 12518  

      il:|changes| il:|to:|  (printers return-node throw-node)
                             (il:vars il:xclc-debugcoms)

      il:|previous| il:|date:| "11-Jan-88 19:40:48" il:{eris}<lispcore>internal>library>xclc-debug.\;1
)


; Copyright (c) 1987, 1988 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:xclc-debugcoms)

(il:rpaqq il:xclc-debugcoms
          (

(il:* il:|;;;| "Debugging support for the XCL Compiler")

           
           (il:* il:|;;| "Printing nodes")

           (il:define-types printers)
           (il:functions defprinter set-pf)
           (il:commands "setpf")
                                                             (il:* il:\; 
                                                           "mv-prog1-node progv-node ")
           (printers block-node call-node catch-node if-node go-node labels-node lambda-node 
                  literal-node mv-call-node mv-prog1-node opcodes-node progn-node return-node 
                  setq-node tagbody-node throw-node unwind-protect-node var-ref-node variable-struct)
           (printers d-assem::dvar d-assem::dtag d-assem::djump d-assem::dlambda d-assem:dcode)
           
           (il:* il:|;;| "Mutator functions for SEdit")

           (il:functions oam eoc)
           
           (il:* il:|;;| "Useful Exec commands")

           (il:commands "ic2")
           
           (il:* il:|;;| "Arrange to use the proper compiler.")

           (il:prop (il:filetype il:makefile-environment)
                  il:xclc-debug)))



(il:* il:|;;;| "Debugging support for the XCL Compiler")




(il:* il:|;;| "Printing nodes")


(def-define-type printers "XCL Compiler node printing functions")

(defdefiner (defprinter (:prototype (lambda (name)
                                               (and (symbolp name)
                                                    `(defprinter ,name ("Object" stream)
                                                                       "Body"))))) printers (type
                                                                                             args 
                                                                                             &body
                                                                                             (body
                                                                                              decls))
   (let ((print-fn (intern (concatenate 'string "\\print-" (string type))
                          (symbol-package type))))
        `(progn (defun ,print-fn (,@args $$depth)
                   (declare (ignore $$depth))
                   ,decls
                   (if (or (null *print-level*)
                           (>= *print-level* 0))
                       (let ((*print-level* (and *print-level* (1- *print-level*))))
                            ,@body)
                       (princ "#" ,(second args))))
                (set-pf ',type ',print-fn))))

(defun set-pf (type fn)
   (let ((ps (cl::parsed-structure type)))
        (and ps (setf (cl::ps-print-function ps)
                      fn))))

(defcommand "setpf" (type fn)
   (let ((ps (cl::parsed-structure type)))
        (and ps (prog1 (cl::ps-print-function ps)
                    (setf (cl::ps-print-function ps)
                          fn)))))



(il:* il:\; "mv-prog1-node progv-node ")


(defprinter block-node (node stream)
                           (format stream "#<Block ~S ~S>" (block-name node)
                                  (block-stmt node)))

(defprinter call-node (call stream)
                          (format stream "#<Call ~S ~{~S~^ ~}>" (call-fn call)
                                 (call-args call)))

(defprinter catch-node (node stream)
                           (format stream "#<Catch ~S ~S>" (catch-tag node)
                                  (catch-stmt node)))

(defprinter if-node (node stream)
                        (format stream "#<If ~S ~S ~S>" (if-pred node)
                               (if-then node)
                               (if-else node)))

(defprinter go-node (node stream)
                        (format stream "#<Go ~S>" (go-tag node)))

(defprinter labels-node (lab stream)
                            (format stream "#<Labels (~{(~S ~S)~}) ~S>"
                                   (mapcan #'(lambda (fn-binding)
                                                    (list (car fn-binding)
                                                          (cdr fn-binding)))
                                          (labels-funs lab))
                                   (labels-body lab)))

(defprinter lambda-node (lam stream)
                            (format
                             stream "#<Lambda ~:S ~S>"
                             `(,@(lambda-required lam)
                               ,@(and (lambda-optional lam)
                                      (cons '&optional
                                            (il:for opt-var il:in (lambda-optional lam)
                                               il:collect
                                               (if (and (literal-p (second opt-var))
                                                        (null (literal-value (second opt-var)))
                                                        (null (third opt-var)))
                                                   (first opt-var)
                                                   opt-var))))
                               ,@(and (lambda-rest lam)
                                      (list '&rest (lambda-rest lam)))
                               ,@(and (lambda-keyword lam)
                                      (cons '&key
                                            (il:for key-var il:in (lambda-keyword lam)
                                               il:collect (cond
                                                                 ((and (string= (first key-var)
                                                                              (variable-name
                                                                               (second key-var)))
                                                                       (literal-p (third key-var))
                                                                       (null (literal-value
                                                                              (third key-var)))
                                                                       (null (fourth key-var)))
                                                                  (second key-var))
                                                                 ((string= (first key-var)
                                                                         (variable-name (second
                                                                                         key-var)))
                                                                  (cdr key-var))
                                                                 (t `((,(first key-var)
                                                                       ,(second key-var))
                                                                      ,@(cddr key-var)))))))
                               ,@(and (lambda-allow-other-keys lam)
                                      (list '&allow-other-keys)))
                             (lambda-body lam)))

(defprinter literal-node (lit stream)
                             (format stream "#<Lit: ~S>" (literal-value lit)))

(defprinter mv-call-node (obj stream)
                             (format stream "#<MV-Call: ~S~{~^ ~S~}>" (mv-call-fn obj)
                                    (mv-call-arg-exprs obj)))

(defprinter mv-prog1-node (node stream)
                              (format stream "#<MV-Prog1: ~{~S~^ ~}>" (mv-prog1-stmts node)))

(defprinter opcodes-node (node stream)
                             (let ((*package* (il:loadtimeconstant (find-package "IL")))
                                   (*print-case* :downcase))
                                  (format stream "#<Opcodes ~{~S~^ ~}>" (opcodes-bytes node))))

(defprinter progn-node (node stream)
                           (format stream "#<Progn ~{~S~^ ~}>" (progn-stmts node)))

(defprinter return-node (node stream)
                            (format stream "#<Return ~S ~S>" (return-block node)
                                   (return-value node)))

(defprinter setq-node (node stream)
                          (format stream "#<Setq ~S ~S>" (variable-name (setq-var node))
                                 (setq-value node)))

(defprinter tagbody-node (node stream)
                             (princ "#<Tagbody" stream)
                             (dolist (segment (tagbody-segments node))
                                 (format stream "~{ ~S~}~{ ~S~}" (segment-tags segment)
                                        (segment-stmts segment)))
                             (princ ">" stream))

(defprinter throw-node (node stream)
                           (format stream "#<Throw ~S ~S>" (throw-tag node)
                                  (throw-value node)))

(defprinter unwind-protect-node (up stream)
                                    (format stream "#<U-P ~S ~S>" (unwind-protect-stmt up)
                                           (unwind-protect-cleanup up)))

(defprinter var-ref-node (ref stream)
                             (format stream "#<Ref: ~S>" (var-ref-variable ref)))

(defprinter variable-struct (var stream)
                                (format stream "#<~A: ~S>" (case (variable-kind var)
                                                               (:function "Fn")
                                                               (:variable "Var"))
                                       (variable-name var)))

(defprinter d-assem::dvar (d-assem::var stream)
                              (format stream "#<DVar ~S>" (d-assem::dvar-name d-assem::var)))

(defprinter d-assem::dtag (d-assem::tag stream)
                              (format stream "#<DTag @ ~O,~O>" (il:\\hiloc d-assem::tag)
                                     (il:\\loloc d-assem::tag)))

(defprinter d-assem::djump (d-assem::jump stream)
                               (format stream "#<DJump @ ~O,~O>" (il:\\hiloc d-assem::jump)
                                      (il:\\loloc d-assem::jump)))

(defprinter d-assem::dlambda (d-assem::dlambda stream)
                                 (format stream "#<DLambda ~S>" (d-assem::dlambda-name 
                                                                       d-assem::dlambda)))

(defprinter d-assem:dcode (d-assem:dcode stream)
                              (format stream "#<DCode ~S>" (d-assem::dcode-frame-name d-assem:dcode)))



(il:* il:|;;| "Mutator functions for SEdit")


(defun oam (form)
   (copy-tree (optimize-and-macroexpand-1 form (il:loadtimeconstant (make-env))
                     (il:loadtimeconstant (make-context)))))

(defun eoc (form)
   (let ((*environment* (il:loadtimeconstant (make-env)))
         (*context* (il:loadtimeconstant (make-context)))
         (fn (car form))
         (args (cdr form)))
        (assert (eq (car fn)
                    'il:openlambda)
               nil "EOC called on a non-OPENLAMBDA")
        (expand-openlambda-call fn args)))



(il:* il:|;;| "Useful Exec commands")


(defcommand "ic2" (xcl-user::hi xcl-user::lo)
   (flet ((xcl-user::octal (xcl-user::n)
                 (read-from-string (format nil "#o~D" xcl-user::n))))
         (let ((xcl-user::code (il:\\vag2 (xcl-user::octal xcl-user::hi)
                                      (xcl-user::octal xcl-user::lo))))
              (if (compiled-function-p xcl-user::code)
                  (il:inspectcode xcl-user::code)
                  (inspect xcl-user::code)))))



(il:* il:|;;| "Arrange to use the proper compiler.")


(il:putprops il:xclc-debug il:filetype :compile-file)

(il:putprops il:xclc-debug il:makefile-environment (:readtable "XCL" :package "COMPILER"))
(il:putprops il:xclc-debug il:copyright ("Xerox Corporation" 1987 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop
\ No newline at end of file
diff --git a/internal/makesysout/HOWTO-MAKE-SYSOUT.TEDIT b/internal/makesysout/HOWTO-MAKE-SYSOUT.TEDIT
new file mode 100644
index 00000000..400adf15
Binary files /dev/null and b/internal/makesysout/HOWTO-MAKE-SYSOUT.TEDIT differ
diff --git a/internal/makesysout/SYNCLISPFILES b/internal/makesysout/SYNCLISPFILES
new file mode 100644
index 00000000..15520455
--- /dev/null
+++ b/internal/makesysout/SYNCLISPFILES
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "11-Aug-2020 16:49:39" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>makesysout>SYNCLISPFILES.;38 9259   

      changes to%:  (FNS SYNCLISPFILES)

      previous date%: "11-Aug-2020 16:04:17" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>makesysout>SYNCLISPFILES.;34)


(PRETTYCOMPRINT SYNCLISPFILESCOMS)

(RPAQQ SYNCLISPFILESCOMS ((FNS SYNCLISPFILES ENDLOADUP MEDLEYVERSION NOPUPPATCH)
                              (INITVARS (WRITELISPSYSOUTFLAG T))
                              (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (SYNCLISPFILES)))
                              (PROP FILETYPE SYNCLISPFILES)))
(DEFINEQ

(SYNCLISPFILES
  [LAMBDA (NODRIBBLE KEEPPUP)                           (* ; "Edited 11-Aug-2020 16:49 by rmk:")
                                                            (* ; "Edited 20-Apr-2018 18:28 by rmk:")

    (* ;; "This ensures that  files in the xlisp.sysout are as up-to-date as possible with respect to lispcore/sources. Reload (compiled, if possible) files that correspond to symbolic files whose filedates are later than the filedate in the system. If you want a new compilation of a file that has not been modified to be included, then you must make a trivial update of the symbolic file and recompile it, to give it a new, later date.  This is because it is unsafe as a general default to load compiled files with dates later than the sysout, and the sysout doesn't record the dates of loaded compiled files, just their symbolic versions.")

    (* ;; " Should be run while connected to lispcore/")

    (CLRPROMPT)
    (CNDIR (UNIX-GETENV "LOADUPDIR"))
    (SETQ LISPMAKESYSDATE MAKESYSDATE)
    (LET (SKIPFILES (ROOTDIRECTORY (DIRECTORYNAME T)))
         (SETQ MAKESYSFILENAME (PACK* ROOTDIRECTORY "xlisp.sysout"))

         (* ;; 
      "FASLOAD has to come first, unconditionally, to get the DFASL file dates converted properly.")

         (SETQ LISPUSERSDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/library")
                                          (PACK* ROOTDIRECTORY "/lispusers")))
         (SETQ DIRECTORIES (APPEND (PACK* ROOTDIRECTORY "/sources")))
         (CL:UNLESS NODRIBBLE
             (DRIBBLE (PACK* ROOTDIRECTORY "/xlisp.dribble")))
         (BKSYSBUF " ")
         (PRINTOUT T T "Synchronizing Lisp sysout at " (DATE)
                " while connected to " ROOTDIRECTORY T T)
         (PUSH SKIPFILES 'FASLOAD)
         (LOAD 'sources/FASLOAD.DFASL 'SYSLOAD)              (* ; 
                                                           "Lisp macros don't show everything")
                                                             (* ; 
              "(PUSH SKIPFILES 'INSPECT)(DREMOVE (FASSOC 'READTABLEP INSPECTMACROS) INSPECTMACROS)")
         (PUSH SKIPFILES 'ATBL)                          (* ; 
                                                   "Whole file can't be reloaded--smashes readtabl")
         (LOADFNS '(\ATBLSET \MAPCHARTABLE RESETREADTABLE)
                'sources/ATBL.LCOM
                'SYSLOAD)
         (LOADVARS '\KEYNAMES 'sources/LLKEY 'SYSLOAD)       (* ; "Extended keynames for Mac/PC")
         (PUSH SKIPFILES 'LLKEY)                         (* ; "Loading whole file freezes")
         (PUSH SKIPFILES 'MAIKOLOADUPFNS)                (* ; 
                                                    "Can't reload even if compiled files are later")
         (FOR LF FF CFILE LOADEDDATE FILEDATE IFILEDATE NOCOMPILEDFILES CFILES (COUNT _ 0)
                (SOURCEDIR _ (CONCAT ROOTDIRECTORY "/sources/")) IN (LDIFFERENCE SYSFILES 
                                                                               SKIPFILES)
            DO [SETQ LOADEDDATE (CAAR (GETP LF 'FILEDATES]
                  (CL:UNLESS LOADEDDATE
                      (PRINTOUT T T LF 
                             " does not have a loaded filedate, probably not a Lisp file; skipped" T)
                      (GO $$ITERATE))
                  (SETQ FF (PACKFILENAME.STRING 'NAME LF 'BODY SOURCEDIR))
                  (SETQ FILEDATE (FILEDATE FF))
                  (CL:UNLESS FILEDATE
                      (PRINTOUT T LF " does not have a file-directory date, not updated" T)
                      (GO $$ITERATE))
                  (SETQ CFILES (FOR EXT IN *COMPILED-EXTENSIONS*
                                  WHEN (SETQ CFILE (INFILEP (PACKFILENAME.STRING 'EXTENSION EXT
                                                                       'BODY FF))) COLLECT CFILE)
                   )
                  (SETQ CFILE (IF CFILES
                                  THEN 

                                        (* ;; 
                                      "If more than one (LCOM, DFASL), pick the newest one.")

                                        (FOR CF IN CFILES
                                           LARGEST (IDATE (FILEDATE CF T)))
                                ELSE (PRINTOUT T "Note: No compiled file for " LF T)
                                      (PUSH NOCOMPILEDFILES LF)
                                      FF))
                  (SETQ IFILEDATE (IDATE FILEDATE))
                  (CL:UNLESS (IGREATERP IFILEDATE 0)
                      (PRINTOUT T "Funny file date " FILEDATE " for " LF ", not updated" T)
                      (GO $$ITERATE)) 

                  (* ;; "Load the compiled file if the date of the symbolic file is later than the symbolic file-date in the sysout.")

                  (IF (IGREATERP IFILEDATE (IDATE LOADEDDATE))
                      THEN (ADD COUNT 1)
                            (LOAD CFILE 'SYSLOAD))
            FINALLY (PRINTOUT T T T COUNT " files loaded" T)
                  (CL:WHEN NOCOMPILEDFILES (PRINTOUT T "Symbolic files loaded:  " .PPVTL 
                                                  NOCOMPILEDFILES T T)))

         (* ;; "Load from patch directory")

         (FOR PF (COUNT _ 0) IN (FILDIR (PACKFILENAME.STRING 'NAME "*.;" 'BODY
                                                           (CONCAT ROOTDIRECTORY "/patches/")))
            DO (FOR EXT CFILE IN *COMPILED-EXTENSIONS*
                      WHEN (SETQ CFILE (INFILEP (PACKFILENAME.STRING 'EXTENSION EXT 'BODY PF)))
                      DO (ADD COUNT 1)
                            (LOAD CFILE 'SYSLOAD)            (* ; "symbolic file date")
                            (RETURN) FINALLY (PRINTOUT T "Note: No compiled file for " PF T)
                                           (ADD COUNT 1)
                                           (LOAD PF 'SYSLOAD))
            FINALLY (PRINTOUT T T T COUNT " files loaded" T))
         (CL:UNLESS KEEPPUP (NOPUPPATCH))
         (ENDLOADUP)
         (CL:WHEN WRITELISPSYSOUTFLAG
             (PRINTOUT T "Creating updated LISP sysout on " MAKESYSFILENAME T)
             (CLRPROMPT)
             (BKSYSBUF (CONCAT "(IL:MAKESYS %"" MAKESYSFILENAME "%" %"Medley Lisp Sysout%")")))
         (CL:UNLESS NODRIBBLE (DRIBBLE])

(ENDLOADUP
  [LAMBDA NIL                                                (* ; "Edited 11-Oct-90 11:02 by jds")

    (* ;; "set up for NONET configuration;  sites with ethernet can load in init from other places")

    (* ;; "All records existing at this point in time have been loaded as part of the system.")

    [MAPC USERRECLST (FUNCTION (LAMBDA (R)
                                 (RECORDPRIORITY R 'SYSTEM]
    [MAPC SYSTEMINITVARS (FUNCTION (LAMBDA (X)
                                     (SETTOPVAL (CAR X)
                                            (COPY (CDR X]
    (COND
       ((NEQ \MACHINETYPE \MAIKO)

        (* ;; 
      "On a non-SUN loadup, need to clear out two fields in the Interface Page, per AR 11276. JDS")

        (replace (IFPAGE ProcessSize) of \InterfacePage with 0)
        (replace (IFPAGE StorageFullState) of \InterfacePage with 0])

(MEDLEYVERSION
  [LAMBDA NIL                                           (* ; "Edited 25-Mar-2018 22:07 by rmk:")
                                                             (* ; "Edited 11-Nov-98 22:02 by rmk:")
    (SELECTQ (LISPVERSION)
        (39424 '|1.1|)
        (39539 '|1.15|)
        (40960 '|1.2|)
        (4928 '|2.0|)
        (21000 '|2.1|)
        (35000 '|3.5|)
        (35010 '|3.5|)
        (HELP "UNRECOGNIZED MEDLEY VERSION" (LISPVERSION])

(NOPUPPATCH
  [LAMBDA NIL                                           (* ; "Edited 14-May-2018 12:22 by rmk:")

    (* ;; "Fix it so pup stuff never gets run")

    (SETQ \PROCESSES (DREMOVE (FIND.PROCESS '\PUPGATELISTENER)
                            \PROCESSES))
    (SETQ \FILEDEVICES (FOR F IN \FILEDEVICES UNLESS (STRPOS "LEAF" F) COLLECT F))
    (MOVD 'NILL '\CANONICALIZE.PUP.HOSTNAME])
)

(RPAQ? WRITELISPSYSOUTFLAG T)
(DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY 

(SYNCLISPFILES)
)

(PUTPROPS SYNCLISPFILES FILETYPE :TCOMPL)
(PUTPROPS SYNCLISPFILES COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (699 9035 (SYNCLISPFILES 709 . 7210) (ENDLOADUP 7212 . 8128) (MEDLEYVERSION 8130 . 8608)
 (NOPUPPATCH 8610 . 9033)))))
STOP
\ No newline at end of file
diff --git a/internal/makesysout/initcommands.txt b/internal/makesysout/initcommands.txt
new file mode 100644
index 00000000..3395ce45
--- /dev/null
+++ b/internal/makesysout/initcommands.txt
@@ -0,0 +1,4 @@
+lldb ../../maiko/darwin.386/ldeinit
+
+break set -n error
+run ./INIT.DLINIT -INIT -NF
diff --git a/internal/makesysout/makefullsysout b/internal/makesysout/makefullsysout
new file mode 100644
index 00000000..4c14c959
--- /dev/null
+++ b/internal/makesysout/makefullsysout
@@ -0,0 +1 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "11-Aug-2020 17:53:49" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>makesysout>makefullsysout.;99 14068  

      changes to%:  (FNS LOADFULLFONTS)

      previous date%: " 1-Aug-2020 20:50:28" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>makesysout>makefullsysout.;98)


(PRETTYCOMPRINT MAKEFULLSYSOUTCOMS)

(RPAQQ MAKEFULLSYSOUTCOMS
       ((COMMANDS "cd" "pwd" "ls")
        (FNS LOADFULLFONTS LOADNFS MAKEFULLSYSOUT PAGEHEIGHT FIXMETA)
        (P (FIXMETA))
        (FNS LoadPatches COLLECT-PATCH-FILES)
        (INITVARS (WRITEFULLSYSOUTFLAG T))
        (VARS (COPYRIGHTFLG NIL))
        (GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS)
        (DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY (P (MAKEFULLSYSOUT)))
        (PROP FILETYPE MAKEFULLSYSOUT)))

(DEFCOMMAND "cd" (DIR) (/CNDIR DIR))

(DEFCOMMAND "pwd" NIL (DIRECTORYNAME T))

(DEFCOMMAND "ls" (FIRST . REST) (DODIR (CONS FIRST REST)))
(DEFINEQ

(LOADFULLFONTS
  [LAMBDA (ROOTDIRECTORY)                               (* ; "Edited 11-Aug-2020 17:53 by rmk:")

    (* ;; " Don't do Interpress. Do character set 0 and the symbol character sets 41Q, 42Q, 356Q, 357Q and extended and accented Latin 43Q and 361Q")

    (PRINTOUT T "Loading FULL fonts..." T)
    (SETQ DISPLAYFONTDIRECTORIES (LIST (PACK* ROOTDIRECTORY "/fonts/displayfonts")
                                       (PACK* ROOTDIRECTORY "/fonts/altofonts")))
                                                             (* (SETQ INTERPRESSFONTDIRECTORIES
                                                           (CONS (PACK* ROOTDIRECTORY 
                                                           "/fonts/ipfonts"))))
    (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE))
    (SETQ POSTSCRIPTFONTDIRECTORIES (CONS (PACK* ROOTDIRECTORY "/fonts/postscriptfonts")))
    (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT)
    (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL)
                (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL))    (* ; 
                  "Don't let the font loader substitute just because a server went catatonic on us")
               (FOR FAMILY IN '(CLASSIC MODERN TERMINAL)
                  DO (PRINTOUT T "  Loading " FAMILY " ")
                        [FOR SIZE IN '(8 10 12)
                           DO (PRINTOUT T SIZE " ")
                                 (FOR FACE IN '(MRR BRR MIR)
                                    DO 

                                          (* ;; "No need for Interpress")
                                                             (* (NLSETQ (FONTCREATE FAMILY SIZE 
                                                           FACE NIL (QUOTE INTERPRESS) NIL 0)))
                                          (FOR CSET
                                             IN '(0 33 34 35 238 239 241)
                                             DO (NLSETQ (FONTCREATE FAMILY SIZE FACE NIL
                                                                   'DISPLAY NIL CSET]
                        (PRINTOUT T T))
               (PRINTOUT T "  Loading postscript fonts" T)
               (FOR F IN (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES)
                                                ">c0>*.*")) DO (PSCFONT.READFONT F))
               (PRINTOUT T "FULL fonts loaded" T])

(LOADNFS
  [LAMBDA NIL                                                (* ; "Edited 11-Nov-98 22:01 by rmk:")
                                                             (* ; 
                                                           "Edited  8-Jun-94 14:20 by kaplan")
                                                             (* ; "Edited 16-Mar-90 14:07 by bbb")

(* ;;; "Function assumes that all directories are properly set")

(* ;;; "loads MINI-NFS and other related files")

    (FILESLOAD (SYSLOAD FROM "{dsk}<project>medley3.5>nfs>")
           MINI-NFS)
    [COND
       (T                                                    (* ; 
                                       "Load Bill's patch to allow Sun users to refer to server/n.")
          (FILESLOAD (SYSLOAD)
                 UFSNFS))
       (T 
          (* ;; "Pray...")

          (\DEFINEDEVICE 'nfs 'dsk]
    (FILESLOAD (SYSLOAD FROM "{dsk}<project>medley3.5>nfs>")
           RPCOS)
    (FILESLOAD (SYSLOAD)
           UNIXCOMM UNIXCHAT RWALLSERVER NFSPROTECTION])

(MAKEFULLSYSOUT
  [LAMBDA NIL                                                (* ; 
                                                           "Edited 14-May-2018 15:01 by kaplan")
                                                             (* ; 
                                                           "Edited  1-Aug-2020 20:50 by rmk:")
                                                             (* ; "Edited 17-Apr-2018 08:41 by ")
                                                             (* ; 
                                                           "Edited 21-Apr-2018 07:27 by rmk:")
                                                             (* ; "Edited 23-Feb-94 15:04 by bvm")
                                                             (* ; "Edited  2-Apr-90 14:42 by bbb")

(* ;;; "This file makes xfull35.sysout based on Venue's Lisp.sysout 3.5.  Start LISP.SYSOUT, connect to MEDLEYDIR for Lisp, connect to MEDLEYDIR/lispcore for lispcore.  Then load makefullsysout/MAKEFULLSYSOUT.LCOM.")

(* ;;; "If sysout looks good, copy to release (basics?)")

(* ;;; "")

    (CLRPROMPT)
    (CNDIR (UNIX-GETENV "LOADUPDIR"))
    (LET ((ROOTDIRECTORY (DIRECTORYNAME T)))                 (* ; 
                                                        "E.g. medley3.5/lisp or medley3.5/lispcore")
         (SETQ MAKESYSFILENAME (PACK* ROOTDIRECTORY "xfull35.sysout"))
                                                             (* ; "Should bind MAKESYSFILENAME")
         (DRIBBLE (PACKFILENAME 'EXTENSION 'dribble 'BODY MAKESYSFILENAME))

         (* ;; "BKSYSBUF stops page holding ")

         (PRINTOUT T T "Full loadup started at " (DATE)
                " while connected to "
                (DIRECTORYNAME T)
                T T)
         (BKSYSBUF " ")
         (SETQ DEFAULTFILETYPE 'BINARY)                      (* ; 
                                      "These prevent bits from being lost due to lack of knowledge")
         (DREMOVE (ASSOC NIL DEFAULTFILETYPELIST)
                DEFAULTFILETYPELIST)                         (* (SETQ *UPPER-CASE-FILE-NAMES* NIL))
         (SETQ MAKESYSNAME :MEDLEY3.5)
         (PUSH DEFAULTFILETYPELIST '(TXT . TEXT)
                '(TEXT . TEXT)
                '(TEX . TEXT)
                '(HTML . TEXT)
                '(HTM . TEXT))
         (SETQ LISPSOURCEDIRECTORIES (LIST (PACK* ROOTDIRECTORY "sources")))
         (SETQ LISPUSERSDIRECTORIES (LIST (PACK* ROOTDIRECTORY "library")
                                          (PACK* ROOTDIRECTORY "lispusers")))
         (SETQ DIRECTORIES (APPEND LISPUSERSDIRECTORIES LISPSOURCEDIRECTORIES DIRECTORIES))
         (SETQ LOADUPDIRECTORIES DIRECTORIES)

         (* ;; "(FILESLOAD (SYSLOAD FROM VALUEOF (PACK* ROOTDIRECTORY %"patches%")) FINDFONTPATCH)")

         (LOADUP '(POSTSCRIPTSTREAM))                        (* ; " to get PSCFONT.READFONT")
         (LOADFULLFONTS ROOTDIRECTORY)
         (LISTPUT IDLE.PROFILE 'TIMEOUT 0)
         (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)           (* ; "Skip DOSPRINT, assume only UNIX")
         (LOADUP '(CHAT NSCHAT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES 
                        GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT 
                        UNICODE ISO8859IO CLIPBOARD MACINTERFACE))

         (* ;; "Useful SSL stuff ")

         (AND NIL (FILESLOAD (SYSLOAD)
                         NSMAINTAIN NSPROTECTION))
         (FILESLOAD (SYSLOAD)
                PRETTYFILEINDEX WHO-LINE NSCOPYFILE)

         (* ;; "Turn off who-line until after the user has greeted")

         (CL:WHEN (WINDOWP *WHO-LINE*)
                (CLOSEW *WHO-LINE*))
         [SETQ POSTGREETFORMS (APPEND POSTGREETFORMS '((INSTALL-WHO-LINE-OPTIONS]
         (AND NIL (FILESLOAD (SYSLOAD)
                         ARCHIVETOOL))
         (AND NIL (PROGN (SETQ CH.DEFAULT.DOMAIN "PARC")
                         (SETQ CH.DEFAULT.ORGANIZATION "XEROX")
                         (LOADNFS)

                         (* ;; "Load in the newest Lafite")

                         (FILESLOAD (SYSLOAD)
                                LAFITE MIME LAFITE-INDENT NSMAIL NEWNSMAIL UNIXMAIL UNIXTELNET)
                         (FILESLOAD (SYSLOAD)
                                SYSTEM33)))
         (FILESLOAD (SYSLOAD)
                SETDEFAULTPRINTER)

         (* ;; "Load the patches last")

         (FILESLOAD (SYSLOAD)
                LOADPATCHES)
         (LoadPatches (PACK* ROOTDIRECTORY "patches>")
                'SYSLOAD NIL)

         (* ;; "Turn on Meta key for Dorados:  (METASHIFT T)")

         (\DAYTIME0 \LASTUSERACTION)
         (LISTPUT IDLE.PROFILE 'TIMEOUT 20)
         (FOR TYPE IN FILEPKTYPES DO (FILEPKGCHANGES TYPE NIL))
         (PACK* ROOTDIRECTORY "xfull35.sysout")
         (SETTOPVAL 'INITIALS NIL)
         (PROMPTPRINT "About to end loadup")
         (PRINTOUT T "About to end loadup" T)

         (* ;; "From SYNCLISPFILES")

         (ENDLOADUP)
         (CL:WHEN LOGOW (CLOSEW LOGOW))
         (LOGOW)
         (PUSH AFTERMAKESYSFORMS '(CLRPROMPT))

         (* ;; "Set up for making the sysout, if we made it this far.")

         (CL:WHEN WRITEFULLSYSOUTFLAG
             (PRINTOUT T "Creating FULL sysout on " MAKESYSFILENAME T)
             (BKSYSBUF (CONCAT "(IL:MAKESYS %"" MAKESYSFILENAME "%" %"Medley " (MEDLEYVERSION)
                              " Full Sysout%")")))
         (DRIBBLE])

(PAGEHEIGHT
  [LAMBDA (N)                                          (* ; "Edited 20-Jul-88 10:13 by Burwell")

    (* ;; "sets the page height in lines of the screen.")

    (* ;; "20-Jul-88:  Took out the (SETQ \CURRENTDISPLAYLINE 0)")

    (PROG1 \#DISPLAYLINES
        (COND
           ((NUMBERP N)
            (SETQ \#DISPLAYLINES N))))])

(FIXMETA
  [LAMBDA NIL                                           (* ; "Edited 25-Jun-2017 17:12 by rmk:")
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP)
           \CURRENTKEYACTION)
    (KEYACTION 'BLANK-TOP '(METADOWN . METAUP])
)

(FIXMETA)
(DEFINEQ

(LoadPatches
  [LAMBDA (DIRECTORY LDFLG AFTERDATE)                    (* ; "Edited  7-Feb-92 11:50 by bbb")

(* ;;; "Load all compiled files from the directory")

    (DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*))
    (LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS*
                          bind (AFTERIDATE _ (if AFTERDATE
                                                     then (OR (IDATE AFTERDATE)
                                                                  0)
                                                   else 0)) join (COLLECT-PATCH-FILES
                                                                          (DIRECTORYNAME DIRECTORY)
                                                                          EXT AFTERIDATE))
                       (FUNCTION (LAMBDA (X Y)
                                   (LESSP (CDR X)
                                          (CDR Y]            (* ; 
                                                           "files are sorted by increasing date")
         (for file in files do (SELECTQ LDFLG
                                               (HIDDEN       (* ; 
                                                       "Load the file, but don't put it on FILELST")
                                                       (LOAD? (CAR file)
                                                              T)
                                                       (SETQ FILELST (DREMOVE (FILENAMEFIELD
                                                                               (CAR file)
                                                                               'NAME)
                                                                            FILELST)))
                                               (LOAD? (CAR file)
                                                      LDFLG)))
         files])

(COLLECT-PATCH-FILES
  [LAMBDA (DIRECTORY EXT AFTERIDATE)                     (* ; "Edited  7-Feb-92 11:49 by bbb")

    (* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE.  Return list of pairs (file . date).  Omits subdirectories.")

    (RESETLST
        (LET ((FILING.ENUMERATION.DEPTH 1)
              (NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY))
              FILE DATE)
             (bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";")
                                     '(ICREATIONDATE)
                                     '(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN))
                when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY)
                                     NAKED-DIR)
                              (> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE))
                                 AFTERIDATE)) collect (CONS FILE DATE))))])
)

(RPAQ? WRITEFULLSYSOUTFLAG T)

(RPAQQ COPYRIGHTFLG NIL)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS)
)
(DECLARE%: DONTEVAL@LOAD DONTEVAL@COMPILE DOCOPY 

(MAKEFULLSYSOUT)
)

(PUTPROPS MAKEFULLSYSOUT FILETYPE :TCOMPL)
(PUTPROPS MAKEFULLSYSOUT COPYRIGHT (NONE))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1018 10742 (LOADFULLFONTS 1028 . 3467) (LOADNFS 3469 . 4548) (MAKEFULLSYSOUT 4550 . 
10133) (PAGEHEIGHT 10135 . 10496) (FIXMETA 10498 . 10740)) (10758 13697 (LoadPatches 10768 . 12716) (
COLLECT-PATCH-FILES 12718 . 13695)))))
STOP
\ No newline at end of file
diff --git a/internal/makesysout/makeinit.txt b/internal/makesysout/makeinit.txt
new file mode 100644
index 00000000..049a09f8
--- /dev/null
+++ b/internal/makesysout/makeinit.txt
@@ -0,0 +1,89 @@
+Page 1.
+
+HOW TO MAKE SYSOUT ON SUN
+
+Osamu Nakamura; KSPA; Fuji Xerox
+February 20, 1990
+
+This will describe the method to make SYSOUT on Sun.
+
+Until now, it was only possible to make SYSOUT using Dorado.
+It was not possible to create SYSOUT using FX without Dorado (NOTE: "without possessing Dorado?"),
+and, regarding (NOTE: "even considering?") Venue, when considering the longevity of Dorado
+the possibility of creating SYSOUT using Sun is incredibly important.
+
+Currently (this time), due to the leadership/guidance of Venue's John D. Sybalsky
+we report the possibility of creating SYSOUT with Sun.
+
+
+Required Files
+
+1. The MAKEINIT/LOADUP shell script along with any files needed by that shell script.
+Place these files in the /SUNLOADUP directory.
+
+* runloadup
+* FILESETS
+* INIT,MAKEINIT
+* XREM,CM;1
+* LOADUP-REM,CM;
+* LOADUP,LISP;
+
+2. Medley Emulator
+
+* General emulator (LDE below)
+* INIT-specific (NOTE: "special purpose?") emulator (INITLDE below)
+
+Using MAKEINIT produce the INIT,DLINIT specialized (NOTE: same question as with "specific" above) emulators
+
+3. All compiled files making up LISP,SYSOUT
+(all Lispcore/sources files)
+
+4. Medley emulator source files (including the makefile) 
+(if INITLDE already exists, these are unnecessary)
+
+
+
+____
+Page 2.
+
+1. Making INITLDE
+
+Using the INITLDE-specific makefile makeinitlde,
+create INITLDE.
+
+Place INITLDE's object file and the executable in the
+$YOURWORKDIR/init.$ARCH/ directory and 
+
+The make procedure is as follows:
+
+  prompt% mkdir $YOURWORKDIR/init.$ARCH
+    (for $ARCH: if sun4 use "sparc," if sun3 use "mc68020")
+  prompt% cd $YOURWORKDIR/bin 
+  prompt% makeinitlde -e
+    (confirm that the flag -DINIT is included in your compiler message (NOTE: <- some of this text is blacked out, this is my best guess))
+
+This should produce INITLDE '$YOURWORKDIR/init.$ARCH/lde'.
+
+WARNING: Regarding the INITLDE produced with the above procedure, the frame buffer cannot be executed on a cg3,cg6 machine.
+To build an INITLDE that can be run on a cg3,cg6 machine, add -DDISPLAYBUFFER to the makeinitlde OPTFLAGS,
+remove all object files from the $YOURWORKINGDIR/init.$ARCH directory, and run makeinitlde -e.
+
+2. Editing of MAKEINIT/LOADUP shell script and other files
+
+Venue's (NOTE: THIS NEXT WORD IS BLACK IN TWO PLACES AND IS PROBABLY SOMETHING SPECIFIC AND TECHNICAL..."Venue's _") is configured using the MAKEINIT/LOADUP files. Accordingly Venue's _ (NOTE: again, blacked out characters) saved configuration section has to be edited to be used, the relevant sections described below (NOTE: <- this whole paragraph is a rough translation as there was a lot of black, but I think this is roughly it):
+
+FILE:runloadup
+set LDE
+(...hopefully you can read this so I'm not going to re-type it out)
+...
+set SECOND<-REM<-CM
+
+FILE:INIT,MAKEINIT
+DIRECTORIES value
+passname (NOTE: password? Transliterated from katakana this is "passname:" パスネーム) for the FILESETS LOAD
+passname for the FASTINIT.DFASL LOAD
+MAKEINIT's fourth parameter (NOTE: guessing that the word is "parameter" here) 
+DLFIXINIT's third parameter (NOTE: still guessing as above)
+
+FILE: LOADUP-REM.CM
+LOADUP.LISP's LOAD password ("passname" again)
diff --git a/internal/makesysout/sunloadup/FASTINIT b/internal/makesysout/sunloadup/FASTINIT
new file mode 100644
index 00000000..9ca76db7
--- /dev/null
+++ b/internal/makesysout/sunloadup/FASTINIT
@@ -0,0 +1,82 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(FILECREATED "26-Jan-90 11:46:56" |{DSK}/home/neptune/jds/FASTINIT.;1| 2946   
+
+      |changes| |to:|  (VARS FASTINITCOMS)
+                       (FNS FASTSETAW FASTSETA FASTELTW FASTELT))
+
+
+(PRETTYCOMPRINT FASTINITCOMS)
+
+(RPAQQ FASTINITCOMS (
+                         (* |;;| 
+                   "Function definitions for the \"fast\" array accessors used in making the INIT.")
+
+                         
+                         (* |;;| 
+                       "<...>Library>VMEM defines these as ELT & SETA, which aren't too fast.")
+
+                         
+                         (* |;;| 
+                       "This is an attempt to speed up INIT building on Suns. --JDS 1/26/90")
+
+                         (FNS FASTELT FASTELTW FASTSETA FASTSETAW)))
+
+
+
+(* |;;| "Function definitions for the \"fast\" array accessors used in making the INIT.")
+
+
+
+
+(* |;;| "<...>Library>VMEM defines these as ELT & SETA, which aren't too fast.")
+
+
+
+
+(* |;;| "This is an attempt to speed up INIT building on Suns. --JDS 1/26/90")
+
+(DEFINEQ
+
+(FASTELT
+  (LAMBDA (A N)                                          (* \; "Edited 26-Jan-90 11:39 by jds")
+
+    (* |;;| "Fast version of pointer-array ELT, for use in building INIT.")
+
+    (PROG ((BASE (|ffetch| (ARRAYP BASE) |of| A))
+           (N0 (IDIFFERENCE N (|ffetch| (ARRAYP ORIG) |of| A))))
+          (SETQ N0 (IPLUS N0 (|ffetch| (ARRAYP OFFST) |of| A)))
+          (RETURN (\\GETBASEPTR (\\ADDBASE2 BASE N0)
+                         0)))))
+
+(FASTELTW
+  (LAMBDA (A N)                                          (* \; "Edited 26-Jan-90 11:40 by jds")
+    (PROG ((BASE (|fetch| (ARRAYP BASE) |of| A))
+           (N0 (IDIFFERENCE N (|fetch| (ARRAYP ORIG) |of| A))))
+          (SETQ N0 (IPLUS N0 (|fetch| (ARRAYP OFFST) |of| A)))
+          (RETURN (\\GETBASE BASE N0)))))
+
+(FASTSETA
+  (LAMBDA (A N V)                                        (* \; "Edited 26-Jan-90 11:41 by jds")
+
+    (* |;;| "Fast version of SETA for pointer arrays for the INIT building code.")
+
+    (PROG ((BASE (|fetch| (ARRAYP BASE) |of| A))
+           (N0 (IDIFFERENCE N (|fetch| (ARRAYP ORIG) |of| A))))
+          (SETQ N0 (IPLUS N0 (|fetch| (ARRAYP OFFST) |of| A)))
+          (RETURN (\\RPLPTR (\\ADDBASE2 BASE N0)
+                         0 V)))))
+
+(FASTSETAW
+  (LAMBDA (A N V)                                        (* \; "Edited 26-Jan-90 11:42 by jds")
+
+    (* |;;| "Fast version of SETA for wrod-arrays, for INIT building code.")
+
+    (PROG ((BASE (|fetch| (ARRAYP BASE) |of| A))
+           (N0 (IDIFFERENCE N (|fetch| (ARRAYP ORIG) |of| A))))
+          (SETQ N0 (IPLUS N0 (|fetch| (ARRAYP OFFST) |of| A)))
+          (RETURN (\\PUTBASE BASE N0 V)))))
+)
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (1126 2923 (FASTELT 1136 . 1622) (FASTELTW 1624 . 1983) (FASTSETA 1985 . 2474) (
+FASTSETAW 2476 . 2921)))))
+STOP
diff --git a/internal/makesysout/sunloadup/FASTINIT-2.0.DFASL b/internal/makesysout/sunloadup/FASTINIT-2.0.DFASL
new file mode 100644
index 00000000..09dbca9e
Binary files /dev/null and b/internal/makesysout/sunloadup/FASTINIT-2.0.DFASL differ
diff --git a/internal/makesysout/sunloadup/FASTINIT.DFASL b/internal/makesysout/sunloadup/FASTINIT.DFASL
new file mode 100644
index 00000000..d58457d7
Binary files /dev/null and b/internal/makesysout/sunloadup/FASTINIT.DFASL differ
diff --git a/internal/makesysout/sunloadup/FILESETS b/internal/makesysout/sunloadup/FILESETS
new file mode 100644
index 00000000..fc1d0976
--- /dev/null
+++ b/internal/makesysout/sunloadup/FILESETS
@@ -0,0 +1,69 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED " 9-Apr-90 16:57:44" {DSK}<users>mitani>SUNLOADUP>FILESETS;2 5281   
+
+      changes to%:  (VARS 1LISPSET)
+
+      previous date%: " 5-Apr-89 16:28:12" {DSK}<users>mitani>SUNLOADUP>FILESETS;1)
+
+
+(* "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT FILESETSCOMS)
+
+(RPAQQ FILESETSCOMS ((* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel") (VARS * FILESETS) (VARS EXPORTFILES) (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) (VARS DEADFNS)))
+
+
+
+(* ;;; "contains all of the lists of files which are used in various ways")
+
+
+
+
+(* ;; 
+"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel"
+)
+
+
+(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET 9LISPSET))
+
+(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE IOCHAR LLKEY LLTIMER))
+
+(RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC LLETHER PUP LEAF PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT))
+
+(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP))
+
+(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE))
+
+(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC))
+
+(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST))
+
+(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH))
+
+(RPAQQ 7LISPSET (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN DPUPFTP FLOPPY))
+
+(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS))
+
+(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM))
+
+(RPAQQ EXPORTFILES (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS))
+
+(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW))
+
+(RPAQQ MAKEINITTYPES ((NIL INIT (0 1) 2LISPSET 1600) (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD LLCHAR TINYPATCH)) (MACROTEST MACROTEST ((MACROTEST) 0 1) 2LISPSET) (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) (NULL NULL ((DUMMY))) (MILLITEST MILLITEST ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) 2LISPSET)))
+
+(RPAQQ RENAMETYPES ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS MODARITH LLFAULT LLKEY LLBFS LLTIMER) (RENAMEDFILE . I-NEW) (SUBNAME . MKI.SUBFNS) (COMSNAME . INEWCOMS) (EXTRACOMS (VARS INITPTRS INITVALUES) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) (MKI.SUBFNS) (INEWCOMS) (VALUES . INITVALUES) (PTRS . INITPTRS) (PREFIX . I.) (VAG2FN . I.VAG2)) (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK RENAMEMACROS MODARITH LLFAULT) (RENAMEDFILE . RDSYS) (SUBNAME . RD.SUBFNS) (COMSNAME . RDCOMS) (EXTRACOMS (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) (RD.SUBFNS (\CALLME . *)) (RDCOMS) (PTRS . RDPTRS) (PREFIX . V) (VAG2FN . VVAG2) (VALUES . RDVALS) (RDPTRS) (RDVALUES))))
+
+(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX))
+
+(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM))
+
+(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) (3LISPSET DLAP) (4LISPSET DFILE DMISC) 7LISPSET (8LISPSET MAKEINIT MEM) 9LISPSET (10LISPSET LLPARAMS) (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE)))
+
+(RPAQQ DEADFNS ((PUTBASE \PUTBASE) (GETBASE \GETBASE) (ADDBASE \ADDBASE) (GETBASEBYTE \GETBASEBYTE) (PUTBASEBYTE \PUTBASEBYTE) (PUTBASEPTR \PUTBASEPTR) (HILOC \HILOC) (LOLOC \LOLOC) (VAG2 \VAG2) (PAGEBASE NIL) (PAGELOC NIL) (WordsPerPage WORDSPERPAGE) (ALTOMACRO DMACRO) (\STACKSPACE ??) (GETBASEPTR \GETBASEPTR) (FPLUS2) (FTIMES2) (CREATECELL \CREATECELL)))
+(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/internal/makesysout/sunloadup/FILESETS.NOETHER b/internal/makesysout/sunloadup/FILESETS.NOETHER
new file mode 100644
index 00000000..5f3a9f88
--- /dev/null
+++ b/internal/makesysout/sunloadup/FILESETS.NOETHER
@@ -0,0 +1,175 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED "15-Feb-90 16:21:14" {DSK}/users/osamu/SUNLOADUP/FILESETS.;1 6850   
+
+      previous date%: " 5-Apr-89 16:28:12" {ERIS}<LISPCORE>SUNLOADUP>FILESETS.;7)
+
+
+(* "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT FILESETSCOMS)
+
+(RPAQQ FILESETSCOMS
+       (
+
+(* ;;; "contains all of the lists of files which are used in various ways")
+
+        
+        (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel")
+
+        
+        (* ;; "'90/02/15 osamu: REMOVE LLETHER from 1LISPSET.")
+
+        (VARS * FILESETS)
+        (VARS EXPORTFILES)
+        (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES)
+        (VARS DEADFNS)))
+
+
+
+(* ;;; "contains all of the lists of files which are used in various ways")
+
+
+
+
+(* ;; 
+"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel"
+)
+
+
+
+
+(* ;; "'90/02/15 osamu: REMOVE LLETHER from 1LISPSET.")
+
+
+(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET
+                           9LISPSET))
+
+(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC
+                           LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS 
+                           LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER))
+
+(RPAQQ 1LISPSET
+       (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM 
+              APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV 
+              CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE
+              XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ 
+              COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS 
+              MAIKOBITBLT MAIKOINIT))
+
+(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP))
+
+(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE))
+
+(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC))
+
+(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST))
+
+(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH))
+
+(RPAQQ 7LISPSET
+       (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT 
+              INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT 
+              CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN
+              DPUPFTP FLOPPY))
+
+(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS))
+
+(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM))
+
+(RPAQQ EXPORTFILES
+       (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW 
+              LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY 
+              ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER
+              LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS))
+
+(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW))
+
+(RPAQQ MAKEINITTYPES
+       ((NIL INIT (0 1)
+             2LISPSET 1600)
+        (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD 
+                                    LLCHAR TINYPATCH))
+        (MACROTEST MACROTEST ((MACROTEST)
+                              0 1)
+               2LISPSET)
+        (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS)))
+        (NANOTEST NANOTEST ((MICROTEST LLSUBRS)))
+        (NULL NULL ((DUMMY)))
+        (MILLITEST MILLITEST
+               ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT 
+                       LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ)))
+        (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1)
+               2LISPSET)))
+
+(RPAQQ RENAMETYPES
+       ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS
+                  MODARITH LLFAULT LLKEY LLBFS LLTIMER)
+           (RENAMEDFILE . I-NEW)
+           (SUBNAME . MKI.SUBFNS)
+           (COMSNAME . INEWCOMS)
+           (EXTRACOMS (VARS INITPTRS INITVALUES)
+                  (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
+                                                          MAKEINIT)))
+           (MKI.SUBFNS)
+           (INEWCOMS)
+           (VALUES . INITVALUES)
+           (PTRS . INITPTRS)
+           (PREFIX . I.)
+           (VAG2FN . I.VAG2))
+        (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK 
+                  RENAMEMACROS MODARITH LLFAULT)
+           (RENAMEDFILE . RDSYS)
+           (SUBNAME . RD.SUBFNS)
+           (COMSNAME . RDCOMS)
+           (EXTRACOMS (FILES VMEM)
+                  (VARS RDVALS RDPTRS)
+                  (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
+                                                          VMEM)))
+           (RD.SUBFNS (\CALLME . *))
+           (RDCOMS)
+           (PTRS . RDPTRS)
+           (PREFIX . V)
+           (VAG2FN . VVAG2)
+           (VALUES . RDVALS)
+           (RDPTRS)
+           (RDVALUES))))
+
+(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10
+                           DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX))
+
+(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM))
+
+(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE)
+                                (3LISPSET DLAP)
+                                (4LISPSET DFILE DMISC)
+                                7LISPSET
+                                (8LISPSET MAKEINIT MEM)
+                                9LISPSET
+                                (10LISPSET LLPARAMS)
+                                (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE)))
+
+(RPAQQ DEADFNS
+       ((PUTBASE \PUTBASE)
+        (GETBASE \GETBASE)
+        (ADDBASE \ADDBASE)
+        (GETBASEBYTE \GETBASEBYTE)
+        (PUTBASEBYTE \PUTBASEBYTE)
+        (PUTBASEPTR \PUTBASEPTR)
+        (HILOC \HILOC)
+        (LOLOC \LOLOC)
+        (VAG2 \VAG2)
+        (PAGEBASE NIL)
+        (PAGELOC NIL)
+        (WordsPerPage WORDSPERPAGE)
+        (ALTOMACRO DMACRO)
+        (\STACKSPACE ??)
+        (GETBASEPTR \GETBASEPTR)
+        (FPLUS2)
+        (FTIMES2)
+        (CREATECELL \CREATECELL)))
+(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/internal/makesysout/sunloadup/FILESETS.ORIG b/internal/makesysout/sunloadup/FILESETS.ORIG
new file mode 100644
index 00000000..ea51dea1
--- /dev/null
+++ b/internal/makesysout/sunloadup/FILESETS.ORIG
@@ -0,0 +1,168 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED " 5-Apr-89 16:28:12" {ERIS}<LISPCORE>SUNLOADUP>FILESETS.;7 7015   
+
+      changes to%:  (VARS 1LISPSET)
+
+      previous date%: " 6-Feb-89 15:49:03" {ERIS}<LISPCORE>SUNLOADUP>FILESETS.;6)
+
+
+(* "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989 by Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT FILESETSCOMS)
+
+(RPAQQ FILESETSCOMS (
+
+(* ;;; "contains all of the lists of files which are used in various ways")
+
+                         
+                         (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel")
+
+                         (VARS * FILESETS)
+                         (VARS EXPORTFILES)
+                         (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES 
+                               DATABASEFILES)
+                         (VARS DEADFNS)))
+
+
+
+(* ;;; "contains all of the lists of files which are used in various ways")
+
+
+
+
+(* ;; 
+"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel"
+)
+
+
+(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET
+                           9LISPSET))
+
+(RPAQQ 0LISPSET 
+       (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT 
+              LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM 
+              LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER))
+
+(RPAQQ 1LISPSET 
+       (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM 
+              APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV 
+              CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE
+              XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC LLETHER PASSWORDS FONT SUNFONT LLDISPLAY 
+              APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT))
+
+(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP))
+
+(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE))
+
+(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC))
+
+(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST))
+
+(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH))
+
+(RPAQQ 7LISPSET 
+       (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT 
+              INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT 
+              CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN
+              DPUPFTP FLOPPY))
+
+(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS))
+
+(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM))
+
+(RPAQQ EXPORTFILES 
+       (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW 
+              LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY 
+              ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER
+              LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS))
+
+(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW))
+
+(RPAQQ MAKEINITTYPES 
+       ((NIL INIT (0 1)
+             2LISPSET 1600)
+        (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD 
+                                    LLCHAR TINYPATCH))
+        (MACROTEST MACROTEST ((MACROTEST)
+                              0 1)
+               2LISPSET)
+        (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS)))
+        (NANOTEST NANOTEST ((MICROTEST LLSUBRS)))
+        (NULL NULL ((DUMMY)))
+        (MILLITEST MILLITEST
+               ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT 
+                       LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ)))
+        (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1)
+               2LISPSET)))
+
+(RPAQQ RENAMETYPES 
+       ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS
+                  MODARITH LLFAULT LLKEY LLBFS LLTIMER)
+           (RENAMEDFILE . I-NEW)
+           (SUBNAME . MKI.SUBFNS)
+           (COMSNAME . INEWCOMS)
+           (EXTRACOMS (VARS INITPTRS INITVALUES)
+                  (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
+                                                          MAKEINIT)))
+           (MKI.SUBFNS)
+           (INEWCOMS)
+           (VALUES . INITVALUES)
+           (PTRS . INITPTRS)
+           (PREFIX . I.)
+           (VAG2FN . I.VAG2))
+        (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK 
+                  RENAMEMACROS MODARITH LLFAULT)
+           (RENAMEDFILE . RDSYS)
+           (SUBNAME . RD.SUBFNS)
+           (COMSNAME . RDCOMS)
+           (EXTRACOMS (FILES VMEM)
+                  (VARS RDVALS RDPTRS)
+                  (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
+                                                          VMEM)))
+           (RD.SUBFNS (\CALLME . *))
+           (RDCOMS)
+           (PTRS . RDPTRS)
+           (PREFIX . V)
+           (VAG2FN . VVAG2)
+           (VALUES . RDVALS)
+           (RDPTRS)
+           (RDVALUES))))
+
+(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10
+                           DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX))
+
+(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM))
+
+(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE)
+                                (3LISPSET DLAP)
+                                (4LISPSET DFILE DMISC)
+                                7LISPSET
+                                (8LISPSET MAKEINIT MEM)
+                                9LISPSET
+                                (10LISPSET LLPARAMS)
+                                (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE)))
+
+(RPAQQ DEADFNS ((PUTBASE \PUTBASE)
+                    (GETBASE \GETBASE)
+                    (ADDBASE \ADDBASE)
+                    (GETBASEBYTE \GETBASEBYTE)
+                    (PUTBASEBYTE \PUTBASEBYTE)
+                    (PUTBASEPTR \PUTBASEPTR)
+                    (HILOC \HILOC)
+                    (LOLOC \LOLOC)
+                    (VAG2 \VAG2)
+                    (PAGEBASE NIL)
+                    (PAGELOC NIL)
+                    (WordsPerPage WORDSPERPAGE)
+                    (ALTOMACRO DMACRO)
+                    (\STACKSPACE ??)
+                    (GETBASEPTR \GETBASEPTR)
+                    (FPLUS2)
+                    (FTIMES2)
+                    (CREATECELL \CREATECELL)))
+(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/internal/makesysout/sunloadup/FILESETS.PUP b/internal/makesysout/sunloadup/FILESETS.PUP
new file mode 100644
index 00000000..cfc9462d
--- /dev/null
+++ b/internal/makesysout/sunloadup/FILESETS.PUP
@@ -0,0 +1,69 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED " 9-Apr-90 16:57:44" {DSK}<users>mitani>SUNLOADUP>FILESETS;2 5281   
+
+      changes to%:  (VARS 1LISPSET)
+
+      previous date%: " 5-Apr-89 16:28:12" {DSK}<users>mitani>SUNLOADUP>FILESETS;1)
+
+
+(* "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT FILESETSCOMS)
+
+(RPAQQ FILESETSCOMS ((* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel") (VARS * FILESETS) (VARS EXPORTFILES) (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) (VARS DEADFNS)))
+
+
+
+(* ;;; "contains all of the lists of files which are used in various ways")
+
+
+
+
+(* ;; 
+"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC.  -- Pavel"
+)
+
+
+(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET 9LISPSET))
+
+(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER))
+
+(RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC LLETHER PUP LEAF PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT))
+
+(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP))
+
+(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE))
+
+(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC))
+
+(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST))
+
+(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH))
+
+(RPAQQ 7LISPSET (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN DPUPFTP FLOPPY))
+
+(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS))
+
+(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM))
+
+(RPAQQ EXPORTFILES (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS))
+
+(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW))
+
+(RPAQQ MAKEINITTYPES ((NIL INIT (0 1) 2LISPSET 1600) (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD LLCHAR TINYPATCH)) (MACROTEST MACROTEST ((MACROTEST) 0 1) 2LISPSET) (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) (NULL NULL ((DUMMY))) (MILLITEST MILLITEST ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) 2LISPSET)))
+
+(RPAQQ RENAMETYPES ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS MODARITH LLFAULT LLKEY LLBFS LLTIMER) (RENAMEDFILE . I-NEW) (SUBNAME . MKI.SUBFNS) (COMSNAME . INEWCOMS) (EXTRACOMS (VARS INITPTRS INITVALUES) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) (MKI.SUBFNS) (INEWCOMS) (VALUES . INITVALUES) (PTRS . INITPTRS) (PREFIX . I.) (VAG2FN . I.VAG2)) (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK RENAMEMACROS MODARITH LLFAULT) (RENAMEDFILE . RDSYS) (SUBNAME . RD.SUBFNS) (COMSNAME . RDCOMS) (EXTRACOMS (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) (RD.SUBFNS (\CALLME . *)) (RDCOMS) (PTRS . RDPTRS) (PREFIX . V) (VAG2FN . VVAG2) (VALUES . RDVALS) (RDPTRS) (RDVALUES))))
+
+(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX))
+
+(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM))
+
+(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) (3LISPSET DLAP) (4LISPSET DFILE DMISC) 7LISPSET (8LISPSET MAKEINIT MEM) 9LISPSET (10LISPSET LLPARAMS) (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE)))
+
+(RPAQQ DEADFNS ((PUTBASE \PUTBASE) (GETBASE \GETBASE) (ADDBASE \ADDBASE) (GETBASEBYTE \GETBASEBYTE) (PUTBASEBYTE \PUTBASEBYTE) (PUTBASEPTR \PUTBASEPTR) (HILOC \HILOC) (LOLOC \LOLOC) (VAG2 \VAG2) (PAGEBASE NIL) (PAGELOC NIL) (WordsPerPage WORDSPERPAGE) (ALTOMACRO DMACRO) (\STACKSPACE ??) (GETBASEPTR \GETBASEPTR) (FPLUS2) (FTIMES2) (CREATECELL \CREATECELL)))
+(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP
diff --git a/internal/makesysout/sunloadup/HOWTO-LOADUP-SUNLISP.TXT b/internal/makesysout/sunloadup/HOWTO-LOADUP-SUNLISP.TXT
new file mode 100644
index 00000000..9e250cf3
--- /dev/null
+++ b/internal/makesysout/sunloadup/HOWTO-LOADUP-SUNLISP.TXT
@@ -0,0 +1,173 @@
+Notes on making a Sun Loadup
+
+update Jan. 25, 1990 by osamu
+
+In a medley sysout on cottonmouth do the following:
+
+;;CONN {DSK}/cottonmouth/users/medley/sources/
+
+-- Make sure all the files are current.  There are SUN specific changes to 
+-- the following files:
+
+-- FILESETS: took PUP and LEAF out of 1LISPSET
+
+(CL:IN-PACKAGE "IL")
+
+-- make copyfiles go faster
+
+(SETQ COPYFILESENUMERATE NIL)
+
+(COPYFILES '{ERIS}<LISPCORE>SOURCES>*.* 
+           '{DSK}/cottonmouth/USERS/MEDLEY/SOURCES/ '(>A))
+
+(COPYFILE '{ERIS}<LISPCORE>SUNLOADUP>FILESETS 'FILESETS)
+
+(COPYFILE '{ERIS}<LISPCORE>SUNLOADUP>LOADUP.LISP 'LOADUP.LISP)
+
+(COPYFILE '{ERIS}<LISPCORE>SUNLOADUP>FIX-ETHER.LCOM 'FIX-ETHER.LCOM)
+
+(COPYFILES '{ERIS}<LISPCORE>SUNLOADUP>MAIKOLOADUPFNS.* '{DSK}/cottonmouth/USERS/MEDLEY/SOURCES/ '(>A))
+
+
+-- You will need the instructions on your local directory.
+
+;;;(COPYFILE '{ERIS}<LISPCORE>SUNLOADUP>HOWTO-LOADUPSUN.TXT '{DSK}HOWTO-LOADUP-SUNLISP.TXT) 
+
+-- set the directories so you can find all the proper files...
+
+;;;(SETQ DIRECTORIES '( 
+;;;"{DSK}/home2/will/sybalsky/lispcore/Sources/" 
+;;;		"{DSK}/home2/will/sybalsky/lispcore/library/" 
+;;;		"{DSK}/home2/will/sybalsky/lispcore/internal/library/" ;;;"{dsk}/home2/will/sybalsky/lispcore/sunloadup/"))
+
+(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG")
+
+;(SETQ DIRECTORIES '( 
+;"{DSK}~/SUNLOADUP/lispcore/Sources/" 
+;		"{DSK}~/SUNLOADUP/lispcore/library/" 
+;		"{DSK}~/SUNLOADUP/lispcore/internal/library/" "{dsk}~/SUNLOADUP/lispcore/sunloadup/"))
+
+(SETQ DIRECTORIES '( 
+"{DSK}/users/sybalsky/lispcore/Sources/" 
+		"{DSK}/users/sybalsky/lispcore/library/" 
+		"{DSK}/users/sybalsky/lispcore/internal/library/" "{dsk}/users/sybalsky/lispcore/sunloadup/"))
+
+
+--you really want the source code for this
+
+(LOAD 'FILESETS)
+
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}/users/sybalsky/FASTINIT.DFASL")
+
+-- turn off idle or you get stuck.
+
+(IDLE.SET.OPTION 'TIMEOUT T)
+
+-- and start making the init.  This takes about 2.5 hrs.
+
+;(PROGN 
+;  (DORENAME 'I)
+;  (DLFIXINIT
+;   (MAKEINIT '(11500Q 13062Q 25400Q)
+;      NIL NIL
+;      '({DSK}/home2/will/sybalsky/lispcore/Sources/ {dsk}/home2/will/sybalsky/lispcore/sunloadup/ ))
+;   '{DSK}INIT.DLINIT
+;   '{dsk}/medley/project4/venue/LISPDLION.DB
+;   300)
+;  (COPYFILE '{eris}<lispcore>sunloadup>XREM.CM '{DSK}XREM.CM)
+;  (COPYFILE '{eris}<lispcore>sunloadup>LOADUP-REM.CM '{DSK}LOADUP-REM.CM)
+;  (LOGOUT T)
+;)
+(PROGN 
+  (DORENAME 'I)
+  (DLFIXINIT
+   (MAKEINIT '(11500Q 13062Q 25400Q)
+      NIL NIL
+      '({DSK}/users/sybalsky/lispcore/Sources/ {dsk}/users/sybalsky/lispcore/sunloadup/ ))
+   '{DSK}INIT.DLINIT
+   '{dsk}/users/sybalsky/lispcore/next/LISPDLION.DB
+   300)
+  (COPYFILE '{dsk}/users/sybalsky/lispcore/sunloadup/XREM.CM 
+	'{DSK}SUNLOADUP/XREM.CM)
+  (COPYFILE '{dsk}/users/sybalsky/lispcore/sunloadup/LOADUP-REM.CM
+	'{DSK}SUNLOADUP/LOADUP-REM.CM)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
+
+-- Now, if you are on the "loadup" machine, exit medley and go to another
+-- machine.  RLOGIN to the loadup machine and do the following:
+
+-- Build an init-specific lde note: you must have a directory under
+-- the maiko directory called init.ARCH where ARCH is the architecture 
+-- of the machine you will run the lde on.  On a sun4, it would be init.sparc.
+
+cd ~/maiko/bin
+makeinitlde -e
+
+-- connect back to your home directory and make a link to the lde and
+-- ldeether (fill in yourname and machine os and arch in the proper
+-- slots below
+
+cd ~
+ln -s /users/YOURNAME/maiko/init.ARCH/lde
+ln -s /users/YOURNAME/maiko/init.ARCH/ldeether
+
+-- make sure you don't have LDEDESTSYSOUT set as you want the sysout on your home
+-- directory.
+
+-- You will need dbxinit.txt available
+
+-- YOU MUST USE A FRESH COPY OF XREM.CM EVERY TIME YOU TRY THIS AS IT
+-- GETS SMASHED AT STARTUP
+
+cp ~/XREM.CM ~/REM.CM
+
+-- start lde under dbx
+
+-- init lde can't treat 'LDEDESTSYSOUT'
+unsetenv LDEDESTSYSOUT
+
+dbx lde
+
+-- load the dbxinit
+
+source /users/maiko/working/bin/dbxinit.txt
+
+-- now set up to stop on error (before URAID, which loses 'cause 
+-- it can't find the keyboard.)
+
+err
+
+run ~/INIT.DLINIT -INIT -NF
+
+-- this is going to run and eventually log itself out.  when dbx returns, quit
+-- from dbx and presto! You've built the beginnings of a loadup.
+
+---
+
+-- go to the loadup machine and connect to the place where you normally
+-- get your lde from
+
+cd ~/maiko/sunos4.sparc/
+
+-- Get the new REM.CM: (YOU MUST DO THIS EVERYTIME AS
+-- REM.CM gets wasted on startup!!)
+
+cp ~/LOADUP-REM.CM ~/REM.CM
+ldeether
+
+-- Now this is going to march happily through loading files.  When it turns
+-- on the windowworld, you may have to hit the space bar to make it continue.
+
+-- I don't know how to make PUP and LEAF load at this point, but I'm working 
+-- on it.
+
+-- I am also working on integrating the changes to the emulator with the latest
+-- stuff.
+
+-- closure caching is still off.
+
+-- Questions or comments? 
diff --git a/internal/makesysout/sunloadup/INIT.DO-TEST b/internal/makesysout/sunloadup/INIT.DO-TEST
new file mode 100644
index 00000000..3a569f01
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.DO-TEST
@@ -0,0 +1,55 @@
+;; Automatic DO-TEST 
+(in-package "INTERLISP")
+
+;; search path when file not found on current directory
+;(SETQ DIRECTORIES '( 
+;	"{dsk}/usr/local/lde/internal/library/"
+;))
+
+;; paths for display fonts; list the ones that are installed
+(SETQ DISPLAYFONTDIRECTORIES
+  '("{DSK}/usr/local/lde/fonts/display/presentation"
+    "{DSK}/usr/local/lde/fonts/display/publishing"
+    "{DSK}/usr/local/lde/fonts/display/printwheel"
+    "{DSK}/usr/local/lde/fonts/display/miscellaneous"
+    "{DSK}/usr/local/lde/fonts/display/jis1"
+    "{DSK}/usr/local/lde/fonts/display/jis2"
+    "{DSK}/usr/local/lde/fonts/display/chinese"))
+
+;; paths for interpress font widths; list the ones that are installed
+(SETQ INTERPRESSFONTDIRECTORIES
+  '("{DSK}/usr/local/lde/fonts/interpress/presentation"
+    "{DSK}/usr/local/lde/fonts/interpress/publishing"
+    "{DSK}/usr/local/lde/fonts/interpress/printwheel"
+    "{DSK}/usr/local/lde/fonts/interpress/miscellaneous"
+    "{DSK}/usr/local/lde/fonts/interpress/jis1"
+    "{DSK}/usr/local/lde/fonts/interpress/jis2"
+    "{DSK}/usr/local/lde/fonts/interpress/chinese"))
+
+;; let any user with a valid UNIX login to exit Idle mode  
+(LISTPUT IDLE.PROFILE 'AUTHENTICATE 'UNIX)
+(LISTPUT IDLE.PROFILE 'ALLOWED.LOGINS '(*))
+(LISTPUT IDLE.PROFILE 'SAVEVM NIL)
+(IDLE.SET.OPTION 'TIMEOUT T)
+(SETQ |\\BeginDST| 98)
+(SETQ |\\EndDST| 305)
+
+;; edit to have your particular site parameters-- for standalone, short
+;; site name is host name
+
+(SETQ XCL:*LONG-SITE-NAME* 
+(SETQ XCL:*SHORT-SITE-NAME* (UNIX-GETPARM "HOSTNAME")))
+
+;; Now loading DO-TEST and run DO-TEST
+;(load "{DSK}/python1/fuji/TESTTOOL/omake/DO-TEST.DFASL")
+(load "{DSK}~/lispcore/internal/library/DO-TEST.DFASL")
+(il:load? 'masterscope.dfasl)
+
+(il:cndir "{dsk}/python1/fuji/TESTTOOL/LANGUAGE/")
+(xcl-test::do-all-tests
+	:results "{DSK}~/DO-TEST/AUTO-TESTS.results"
+	:patterns '("*.TEST"))
+
+(DATE)
+(PRINT "DO-TEST completed.")
+
diff --git a/internal/makesysout/sunloadup/INIT.LOADFULL b/internal/makesysout/sunloadup/INIT.LOADFULL
new file mode 100644
index 00000000..3bbaf7cf
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.LOADFULL
@@ -0,0 +1,5 @@
+"  
+SHH(LOAD '{DSK}~/SUNLOADUP/LOADFULL.LISP)
+SHH(MAKESYS '{DSK}~/FULL.SYSOUT]
+SHH(LOGOUT] "
+
diff --git a/internal/makesysout/sunloadup/INIT.LOADFULLFROMLISP b/internal/makesysout/sunloadup/INIT.LOADFULLFROMLISP
new file mode 100644
index 00000000..431211f1
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.LOADFULLFROMLISP
@@ -0,0 +1,2 @@
+(PROGN (ILLOAD '{dsk}SUNLOADUP/LOADFULL.LISP) (ILMAKESYS 'FULL.SYSOUT) (ILLOGOUT T))
+
diff --git a/internal/makesysout/sunloadup/INIT.MAKEBIG b/internal/makesysout/sunloadup/INIT.MAKEBIG
new file mode 100644
index 00000000..c458e4a0
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEBIG
@@ -0,0 +1,50 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;	Same as INIT.MAKEINITFULL, but points to DSK for files, not Pele:.
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}~/lispcore/SUNLOADUP/LOADUP.LOG")
+(SETQ CH.DEFAULT.DOMAIN "mv")
+(SETQ CH.DEFAULT.ORGANIZATION "envos")
+(CNDIR "{dsk}~/lispcore/sources/")
+(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0)
+(SETQ CROSSCOMPILING T)
+
+(SETQ DIRECTORIES '(
+	"{dsk}~/lispcore/sources/" "{dsk}~/lispcore/library/"
+	"{DSK}~/lispcore/internal/library/"
+	"{DSK}~/lispcore/sunloadup/" ))
+(LOAD "{dsk}~/lispcore/SUNLOADUP/FILESETS")
+;;(PUTPROP :D8 'CODEREADER (GETPROP :D7 'CODEREADER))
+(LOAD "{dsk}~/lispcore/library/VMEM.LCOM")
+(LOAD "{dsk}~/lispcore/sources/MEM.LCOM")
+(LOAD "{dsk}~/lispcore/library/READSYS.LCOM")
+(LOAD "{dsk}~/lispcore/library/RDSYS.LCOM")
+(LOAD "{DSK}~/lispcore/sources/DTDECLARE.LCOM")
+;; Not when start in .30(LOAD "{DSK}~/lispcore/medley2.01/cmlarray-support.lcom")
+;;(LOADFNS '\MAP-CODE-POINTERS "{dsk}~/lispcore/sources/ACODE.LCOM;1")
+;;(LOADFNS 'VNTYPX "{dsk}~/lispcore/sources/RDSYS.LCOM")
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}~/lispcore/SUNLOADUP/FASTINIT.DFASL")
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 2.5 hrs.
+(CNDIR "{dsk}~/lispcore/4-BYTE-ATOMS/")
+(PROGN 
+(DORENAME 'I)  ;; At times, this is commented out if I-NEW needs hand tweeking...
+  (DLFIXINIT
+   (MAKEINIT '(35010 35010 25400Q)
+      NIL '{dsk}~/lispcore/INIT.SYSOUT
+      '("{dsk}~/lispcore/4-BYTE-ATOMS/" 
+		"{dsk}~/lispcore/sources/"
+		"{dsk}~/lispcore/3-BYTE-ATOMS/"
+	"{DSK}~/lispcore/sunloadup/" ))
+   '{DSK}~/lispcore/INIT.DLINIT
+   '{dsk}~/lispcore/SUNLOADUP/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEBIGFULLFROMLISP b/internal/makesysout/sunloadup/INIT.MAKEBIGFULLFROMLISP
new file mode 100644
index 00000000..5d36eae5
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEBIGFULLFROMLISP
@@ -0,0 +1,13 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;
+(CL:IN-PACKAGE "IL")
+(SETQ DIRECTORIES '(
+	"{dsk}/users/sybalsky/4-BYTE-ATOMS/"
+	"{dsk}/king/export/lispcore/lafite/parc-94/"
+	"{DSK}/users/sybalsky/4-byte-lib/" 
+	"{DSK}/users/sybalsky/4-byte-intlib/"
+	"{DSK}/users/sybalsky/sunloadup/" ))
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEBIGSGI b/internal/makesysout/sunloadup/INIT.MAKEBIGSGI
new file mode 100644
index 00000000..8e1ea878
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEBIGSGI
@@ -0,0 +1,48 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;	Same as INIT.MAKEINITFULL, but points to DSK for files, not Pele:.
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}/users/sybalsky/SUNLOADUP/LOADUP.LOG")
+(SETQ CH.DEFAULT.DOMAIN "mv")
+(SETQ CH.DEFAULT.ORGANIZATION "envos")
+(CNDIR "{dsk}/king/export/lispcore/sources/")
+(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0)
+(SETQ CROSSCOMPILING T)
+
+(SETQ DIRECTORIES '(
+	"{dsk}/king/export/lispcore/sources/" "{dsk}/king/export/lispcore/library/"
+	"{DSK}/king/export/lispcore/internal/library/"
+	"{DSK}/users/sybalsky/sunloadup/" ))
+(LOAD "{dsk}/users/sybalsky/SUNLOADUP/FILESETS")
+(PUTPROP :D8 'CODEREADER (GETPROP :D7 'CODEREADER))
+(LOAD "{dsk}/king/export/lispcore/library/VMEM.LCOM")
+(LOAD "{dsk}/king/export/lispcore/sources/MEM.LCOM")
+(LOAD "{dsk}/king/export/lispcore/library/READSYS.LCOM")
+(LOAD "{dsk}/king/export/lispcore/library/RDSYS.LCOM")
+(LOAD "{DSK}/king/export/lispcore/sources/DTDECLARE.LCOM")
+;;(LOAD "{DSK}/users/sybalsky/medley2.01/cmlarray-support.lcom")
+(LOADFNS '\MAP-CODE-POINTERS "{dsk}/king/export/lispcore/sources/ACODE.LCOM;1")
+(LOADFNS 'VNTYPX "{dsk}/king/export/lispcore/sources/RDSYS.LCOM")
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}/users/sybalsky/SUNLOADUP/FASTINIT.DFASL")
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 2.5 hrs.
+(CNDIR "{dsk}/users/sybalsky/4-BYTE-ATOMS/")
+(PROGN 
+;;  (DORENAME 'I)  ;; At times, this is commented out if I-NEW needs hand tweeking...
+  (DLFIXINIT
+   (MAKEINIT '(21000 21000 25400Q)
+      NIL '{dsk}/users/sybalsky/INIT.SYSOUT
+      '("{dsk}/users/sybalsky/4-BYTE-ATOMS/" 
+	"{DSK}/users/sybalsky/sunloadup/" ))
+   '{DSK}/users/sybalsky/INIT.DLINIT
+   '{dsk}/users/sybalsky/SUNLOADUP/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKECLTL2SGI b/internal/makesysout/sunloadup/INIT.MAKECLTL2SGI
new file mode 100644
index 00000000..f023705b
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKECLTL2SGI
@@ -0,0 +1,51 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;	Same as INIT.MAKEINITFULL, but points to DSK for files, not Pele:.
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}/users/sybalsky/SUNLOADUP/LOADUP.LOG")
+(SETQ CH.DEFAULT.DOMAIN "mv")
+(SETQ CH.DEFAULT.ORGANIZATION "envos")
+(CNDIR "{dsk}~/4-byte-atoms/")
+(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0)
+(SETQ CROSSCOMPILING T)
+
+(SETQ DIRECTORIES '(
+	"{dsk}~/4-byte-lib/" "{dsk}~/4-byte-atoms/" "{dsk}/king/export/lispcore/sources/cltl2/"
+	"{dsk}/king/export/lispcore/sources/" "{dsk}/king/export/lispcore/library/"
+	"{DSK}/king/export/lispcore/internal/library/"
+	"{DSK}/users/sybalsky/sunloadup/" ))
+(LOAD "{dsk}/users/sybalsky/SUNLOADUP/FILESETS")
+(FILESLOAD VMEM MEM READSYS RDSYS)
+;  (LOAD "{dsk}/king/export/lispcore/library/VMEM.LCOM")
+;  (LOAD "{dsk}/king/export/lispcore/sources/MEM.LCOM")
+;  (LOAD "{dsk}/king/export/lispcore/library/READSYS.LCOM")
+;  (LOAD "{dsk}/king/export/lispcore/library/RDSYS.LCOM")
+;  (LOAD "{DSK}/king/export/lispcore/sources/DTDECLARE.LCOM")
+;  (LOAD "{DSK}/users/sybalsky/medley2.01/cmlarray-support.lcom")
+;  (LOADFNS '\MAP-CODE-POINTERS "{dsk}/king/export/lispcore/sources/ACODE.LCOM;1")
+;  (LOADFNS 'VNTYPX "{dsk}/king/export/lispcore/sources/RDSYS.LCOM")
+(LOAD '{dsk}/king/export/lispcore/sources/cltl2/MACHINEINDEPENDENT.LCOM)
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}/users/sybalsky/SUNLOADUP/bigFASTINIT.DFASL")
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 2.5 hrs.
+(CNDIR "{dsk}/king/export/lispcore/sources/cltl2/")
+(PROGN 
+ (DORENAME 'I)
+  (DLFIXINIT
+   (MAKEINIT '(11500Q 13062Q 25400Q)
+      NIL '{dsk}/users/sybalsky/INIT.SYSOUT
+      '("{dsk}/king/export/lispcore/sources/cltl2/"
+		"{dsk}/users/sybalsky/4-BYTE-ATOMS/" 
+	"{DSK}/users/sybalsky/sunloadup/" ))
+   '{DSK}/users/sybalsky/INIT.DLINIT
+   '{dsk}/users/sybalsky/SUNLOADUP/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEINIT b/internal/makesysout/sunloadup/INIT.MAKEINIT
new file mode 100644
index 00000000..f86fd79b
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEINIT
@@ -0,0 +1,48 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG")
+(SETQ DIRECTORIES '(
+	"{dsk}/users/sybalsky/3-byte-atom-changes/"
+	"{pele:mv:envos}<lispcore>sources>" 
+	"{DSK}/usr/local/lde/lispcore/library/" 
+	"{DSK}/usr/local/lde/lispcore/internal/library/"
+	"{DSK}/users/sybalsky/sunloadup/" ))
+(LOAD "{dsk}~/SUNLOADUP/FILESETS")
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL")
+(FOR FILE IN '(xclc-env-ctxt.lcom xclc-top-level.dfasl dtdeclare.lcom lldatatype.lcom bytecompiler.lcom dlap.lcom d-assem.lcom llarrayelt.lcom llcode.lcom set-target)
+  do (LOAD FILE))
+(SET-TARGET NIL)  ;; should effectively replace these lines:
+;(PUTPROP 'FLOAT 'DOPVAL '((1 DTEST 0 (ATOM . FLOATP))))
+;(SETQ COMPILER::*HOST-ARCHITECTURE* NIL)
+;(SETQ COMPILER::*TARGET-ARCHITECTURE* NIL)
+;(SETQ *BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV :PARENT T))
+;
+;  Mark this as making a 3-byte INIT:
+(SETQ COMPILER::*TARGET-ARCHITECTURE* '(:3-BYTE-INIT))
+(SETQ *BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV :PARENT T))
+;
+;
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 2.5 hrs.
+(PROGN 
+  (DORENAME 'I) 
+  (SET-TARGET T)
+
+  (DLFIXINIT
+   (MAKEINIT '(11500Q 13062Q 25400Q)
+      NIL NIL
+      '("{DSK}/users/sybalsky/3-BYTE-ATOMS/" 
+	"{DSK}/users/sybalsky/sunloadup/" ))
+   '{DSK}~/INIT.DLINIT
+   '{dsk}/python1/fuji/sunloadup/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEINIT-3BYTE b/internal/makesysout/sunloadup/INIT.MAKEINIT-3BYTE
new file mode 100644
index 00000000..f86fd79b
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEINIT-3BYTE
@@ -0,0 +1,48 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG")
+(SETQ DIRECTORIES '(
+	"{dsk}/users/sybalsky/3-byte-atom-changes/"
+	"{pele:mv:envos}<lispcore>sources>" 
+	"{DSK}/usr/local/lde/lispcore/library/" 
+	"{DSK}/usr/local/lde/lispcore/internal/library/"
+	"{DSK}/users/sybalsky/sunloadup/" ))
+(LOAD "{dsk}~/SUNLOADUP/FILESETS")
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL")
+(FOR FILE IN '(xclc-env-ctxt.lcom xclc-top-level.dfasl dtdeclare.lcom lldatatype.lcom bytecompiler.lcom dlap.lcom d-assem.lcom llarrayelt.lcom llcode.lcom set-target)
+  do (LOAD FILE))
+(SET-TARGET NIL)  ;; should effectively replace these lines:
+;(PUTPROP 'FLOAT 'DOPVAL '((1 DTEST 0 (ATOM . FLOATP))))
+;(SETQ COMPILER::*HOST-ARCHITECTURE* NIL)
+;(SETQ COMPILER::*TARGET-ARCHITECTURE* NIL)
+;(SETQ *BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV :PARENT T))
+;
+;  Mark this as making a 3-byte INIT:
+(SETQ COMPILER::*TARGET-ARCHITECTURE* '(:3-BYTE-INIT))
+(SETQ *BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV :PARENT T))
+;
+;
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 2.5 hrs.
+(PROGN 
+  (DORENAME 'I) 
+  (SET-TARGET T)
+
+  (DLFIXINIT
+   (MAKEINIT '(11500Q 13062Q 25400Q)
+      NIL NIL
+      '("{DSK}/users/sybalsky/3-BYTE-ATOMS/" 
+	"{DSK}/users/sybalsky/sunloadup/" ))
+   '{DSK}~/INIT.DLINIT
+   '{dsk}/python1/fuji/sunloadup/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEINIT-MAIN b/internal/makesysout/sunloadup/INIT.MAKEINIT-MAIN
new file mode 100644
index 00000000..0e597456
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEINIT-MAIN
@@ -0,0 +1,34 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG")
+(SETQ DIRECTORIES '(
+	"{DSK}/usr/local/lde/lispcore/sources/" 
+	"{DSK}/usr/local/lde/lispcore/library/" 
+	"{DSK}/usr/local/lde/lispcore/internal/library/"
+	"{DSK}/python1/fuji/sunloadup/"
+	"{dsk}/users/sybalsky/lispcore/sunloadup/" ))
+(LOAD "{dsk}SUNLOADUP/FILESETS")
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL")
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 45 min.
+(PROGN 
+  (DORENAME 'I)
+  (DLFIXINIT
+   (MAKEINIT '(11500Q 13062Q 25400Q)
+      NIL NIL
+      '({DSK}/usr/local/lde/lispcore/sources/
+        {dsk}/users/osamu/sunloadup/
+	{DSK}/python1/fuji/sunloadup/ ))
+   '{DSK}INIT.DLINIT
+   '{dsk}/python1/fuji/sunloadup/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEINIT-MAIN% b/internal/makesysout/sunloadup/INIT.MAKEINIT-MAIN%
new file mode 100644
index 00000000..f27b33c8
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEINIT-MAIN%
@@ -0,0 +1,34 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG")
+(SETQ DIRECTORIES '(
+	"{DSK}/usr/local/lde/lispcore/sources/" 
+	"{DSK}/usr/local/lde/lispcore/library/" 
+	"{DSK}/usr/local/lde/lispcore/internal/library/"
+	"{DSK}/python1/fuji/sunloadup/"
+	"{dsk}/users/sybalsky/lispcore/sunloadup/" ))
+(LOAD "{dsk}SUNLOADUP/FILESETS")
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL")
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 2.5 hrs.
+(PROGN 
+  (DORENAME 'I)
+  (DLFIXINIT
+   (MAKEINIT '(11500Q 13062Q 25400Q)
+      NIL NIL
+      '({DSK}/usr/local/lde/lispcore/sources/
+        {dsk}/users/osamu/sunloadup/
+	{DSK}/python1/fuji/sunloadup/ ))
+   '{DSK}INIT.DLINIT
+   '{dsk}/python1/fuji/sunloadup/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEINIT-NOETHER b/internal/makesysout/sunloadup/INIT.MAKEINIT-NOETHER
new file mode 100644
index 00000000..733f821c
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEINIT-NOETHER
@@ -0,0 +1,34 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/15 Osamu
+;	Making LISP.SYSOUT that doesn't support XNS,PUP
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG")
+(SETQ DIRECTORIES '(
+	"{DSK}/users/sybalsky/lispcore/Sources/" 
+	"{DSK}/users/sybalsky/lispcore/library/" 
+	"{DSK}/users/sybalsky/lispcore/internal/library/"
+	"{dsk}/users/sybalsky/lispcore/sunloadup/" ))
+;
+; remove LLETHER from 1LISPSET
+(LOAD "{dsk}/users/osamu/SUNLOADUP/FILESETS")
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}/users/sybalsky/FASTINIT.DFASL")
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 2.5 hrs.
+(PROGN 
+  (DORENAME 'I)
+  (DLFIXINIT
+   (MAKEINIT '(11500Q 13062Q 25400Q)
+      NIL NIL
+      '({DSK}/users/sybalsky/lispcore/Sources/
+        {dsk}/users/sybalsky/lispcore/sunloadup/ ))
+   '{DSK}INIT.DLINIT
+   '{dsk}/users/sybalsky/lispcore/next/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEINITDSK b/internal/makesysout/sunloadup/INIT.MAKEINITDSK
new file mode 100644
index 00000000..b65e9a20
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEINITDSK
@@ -0,0 +1,48 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;	Same as INIT.MAKEINITFULL, but points to DSK for files, not Pele:.
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG")
+(SETQ CH.DEFAULT.DOMAIN "mv")
+(SETQ CH.DEFAULT.ORGANIZATION "envos")
+(CNDIR "{dsk}/king/export/lispcore/sources/")
+(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0)
+(SETQ CROSSCOMPILING T)
+
+(SETQ DIRECTORIES '(
+	"{dsk}/king/export/lispcore/sources/" "{dsk}/king/export/lispcore/library/"
+	"{DSK}/king/export/lispcore/internal/library/"
+	"{DSK}/users/sybalsky/sunloadup/" ))
+(LOAD "{dsk}~/SUNLOADUP/FILESETS")
+(LOAD "{dsk}/king/export/lispcore/library-2.0/VMEM.LCOM")
+(LOAD "{dsk}~/3-BYTE-ATOMS/MEM.LCOM")
+(LOAD "{dsk}/king/export/lispcore/library-2.0/READSYS.LCOM")
+(LOAD "{dsk}/king/export/lispcore/library-2.0/RDSYS.LCOM")
+(LOAD "{DSK}~/3-BYTE-ATOMS/DTDECLARE.LCOM")
+(LOAD "{DSK}/king/export/release/medley/2.0/library/cmlarray-support.lcom")
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL")
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 2.5 hrs.
+(CNDIR "{dsk}~/3-BYTE-ATOMS/")
+(PROGN 
+ ;;(DORENAME 'I)
+  (DLFIXINIT
+   (MAKEINIT '(20101	;LISP VERSION
+               20100	; MIN MICROCODE VERSION FOR XEROX
+               20100 ; MIN EMULATOR VERSION FOR UNIX/DOS, BCPL FOR XEROX
+              )
+      NIL '{dsk}~/INIT.SYSOUT
+      '("{dsk}/users/sybalsky/3-BYTE-ATOMS/" 
+	"{DSK}/users/sybalsky/sunloadup/" ))
+   '{DSK}~/INIT.DLINIT
+   '{dsk}~/SUNLOADUP/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEINITFULL b/internal/makesysout/sunloadup/INIT.MAKEINITFULL
new file mode 100644
index 00000000..1c181619
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEINITFULL
@@ -0,0 +1,41 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG")
+(SETQ CH.DEFAULT.DOMAIN "mv")
+(SETQ CH.DEFAULT.ORGANIZATION "envos")
+(CNDIR "{pele:mv:envos}<medley>2.01>sources>")
+(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0)
+
+(SETQ DIRECTORIES '(
+	"{pele:mv:envos}<medley>2.01>sources>" 
+	"{pele:mv:envos}<medley>2.0>sources>" "{PELE:MV:ENVOS}<medley>2.0>LIBRARY>"
+	"{DSK}/users/sybalsky/sunloadup/" ))
+(LOAD "{dsk}~/SUNLOADUP/FILESETS")
+(LOAD "{pele:mv:envos}<medley>2.0>library>VMEM.LCOM")
+(LOAD "{pele:mv:envos}<medley>2.0>library>READSYS.LCOM")
+(LOAD "{pele:mv:envos}<medley>2.0>library>RDSYS.LCOM")
+(LOAD "{pele:mv:envos}<medley>2.0>library>cmlarray-support.lcom")
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT )
+(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL")
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 2.5 hrs.
+(CNDIR "{dsk}~/3-BYTE-ATOMS/")
+(PROGN 
+  (DORENAME 'I)
+  (DLFIXINIT
+   (MAKEINIT '(11500Q 13062Q 25400Q)
+      NIL '{dsk}~/INIT.SYSOUT
+      '("{dsk}/users/sybalsky/3-BYTE-ATOMS/" 
+	"{DSK}/users/sybalsky/sunloadup/" ))
+   '{DSK}~/INIT.DLINIT
+   '{dsk}~/SUNLOADUP/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEINITFULLFROMLISP b/internal/makesysout/sunloadup/INIT.MAKEINITFULLFROMLISP
new file mode 100644
index 00000000..5d36eae5
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEINITFULLFROMLISP
@@ -0,0 +1,13 @@
+;
+;	Run MAKEINIT on SUN
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;
+(CL:IN-PACKAGE "IL")
+(SETQ DIRECTORIES '(
+	"{dsk}/users/sybalsky/4-BYTE-ATOMS/"
+	"{dsk}/king/export/lispcore/lafite/parc-94/"
+	"{DSK}/users/sybalsky/4-byte-lib/" 
+	"{DSK}/users/sybalsky/4-byte-intlib/"
+	"{DSK}/users/sybalsky/sunloadup/" ))
+)
diff --git a/internal/makesysout/sunloadup/INIT.MAKEINITFULLSGI b/internal/makesysout/sunloadup/INIT.MAKEINITFULLSGI
new file mode 100644
index 00000000..4bf11849
--- /dev/null
+++ b/internal/makesysout/sunloadup/INIT.MAKEINITFULLSGI
@@ -0,0 +1,40 @@
+;
+;	Run MAKEINIT on INDIGO, no NS access
+;	'90/02/09 Osamu
+;	'90.05/23 change DIRECTORIES
+;
+(CL:IN-PACKAGE "IL")
+(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG")
+(SETQ CH.DEFAULT.DOMAIN "mv")
+(SETQ CH.DEFAULT.ORGANIZATION "envos")
+(CNDIR "{dsk}/users/sybalsky/medley2.01>")
+(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0)
+
+(SETQ DIRECTORIES '(
+	"{dsk}<users>sybalsky>medley2.01>" 
+	"{DSK}/users/sybalsky/sunloadup/" ))
+(LOAD "{dsk}~/SUNLOADUP/FILESETS")
+(LOAD "VMEM.LCOM")
+(LOAD "READSYS.LCOM")
+(LOAD "RDSYS.LCOM")
+(LOAD "cmlarray-support.lcom")
+(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT)
+(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL")
+;; turn off idle or you get stuck.
+(IDLE.SET.OPTION 'TIMEOUT T)
+;;and start making the init.  This takes about 2.5 hrs.
+(CNDIR "{dsk}~/3-BYTE-ATOMS/")
+(PROGN 
+  (DORENAME 'I)
+  (DLFIXINIT
+   (MAKEINIT '(11500Q 13062Q 25400Q)
+      NIL '{dsk}~/INIT.SYSOUT
+      '("{dsk}/users/sybalsky/3-BYTE-ATOMS/" 
+	"{DSK}/users/sybalsky/sunloadup/" ))
+   '{DSK}~/INIT.DLINIT
+   '{dsk}~/SUNLOADUP/LISPDLION.DB
+   300)
+  (DATE)
+  (DRIBBLE)
+  (LOGOUT T)
+)
diff --git a/internal/makesysout/sunloadup/LLPARAMS b/internal/makesysout/sunloadup/LLPARAMS
new file mode 100644
index 00000000..55b21afc
--- /dev/null
+++ b/internal/makesysout/sunloadup/LLPARAMS
@@ -0,0 +1,1705 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 8)
+(FILECREATED "31-Jan-98 09:16:51" {DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>LLPARAMS.;15 232505Q
+
+      changes to%:  (VARS INITCONSTANTS)
+
+      previous date%: "30-Jan-98 12:43:29" 
+{DSK}<disk>disk2>jdstools>lc3>lispcore3.0>sources>LLPARAMS.;14)
+
+
+(* ; "
+Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1994, 1998 by Syntelligence Systems, Inc.  This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc.  Reverse engineering, reverse compiling and disassembling of object code are prohibited.  Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc.  Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets.  All rights reserved.
+")
+
+(PRETTYCOMPRINT LLPARAMSCOMS)
+
+(RPAQQ LLPARAMSCOMS (
+                         (* ;; 
+                       "This file defines the constants that control how a SYSOUT is laid out.")
+
+                         (FNS MAKERECORD)
+                         
+                         (* ;; "When you change the SYSOUT's layout in this file, you must also")
+
+                         
+                         (* ;; "   Recreate RDSYS in the library, using (DORENAME 'R)")
+
+                         
+                         (* ;; 
+                   "   Recompile DLFIXINIT and anything else that uses the constants defined here.")
+
+                         
+                         (* ;; "   Recompile LLFAULT. recompile VMEM")
+
+                         (DECLARE%: DONTCOPY
+                                (EXPORT (CONSTANTS (WINDFLG T))
+                                       
+                                       (* ;; 
+                         "INITCONSTANTS are constants (e.g. \LISTPDTD) to be defined at init time.")
+
+                                       (VARS INITCONSTANTS MISCSTATSLAYOUT IFPAGELAYOUT 
+                                             MAIKO.IFPAGELAYOUT IOPAGELAYOUT)
+                                       [CONSTANTS * (for X in INITCONSTANTS when (FIXP (CADR X))
+                                                         collect
+                                                         (LIST (CAR X)
+                                                               (CADR X]
+                                       (CONSTANTS * \MPERRORS)
+                                       (GLOBALVARS * (for X in INITCONSTANTS when
+                                                          [AND (NEQ (CAR X)
+                                                                    '*)
+                                                               (NOT (FIXP (CADR X]
+                                                          collect
+                                                          (CAR X)))
+                                       (P * (LIST (MAKERECORD 'MISCSTATS MISCSTATSLAYOUT)
+                                                  (COND ((EQ \MACHINETYPE \MAIKO)
+                                                         (MAKERECORD 'IFPAGE MAIKO.IFPAGELAYOUT))
+                                                        (T (MAKERECORD 'IFPAGE IFPAGELAYOUT)))
+                                                  (MAKERECORD 'IOPAGE IOPAGELAYOUT)))
+                                       (MACROS EMADDRESS EMGETBASE EMPUTBASE EMULATORSEGMENT 
+                                              EMPOINTER EMADDRESSP)))
+                         (PROP MAKEFILE-ENVIRONMENT LLPARAMS)))
+
+
+
+(* ;; "This file defines the constants that control how a SYSOUT is laid out.")
+
+(DEFINEQ
+
+(MAKERECORD
  [LAMBDA (NAME LAYOUT)                                  (* bvm%: "29-NOV-82 17:40")
    (PROG ((I 0)
           PTRS M NAM)
          (RETURN
           `(BLOCKRECORD
             %, NAME %,
             [for X in LAYOUT
                collect (CONS (SETQ NAM (CAR X))
                                  (COND
                                     ((EQ NAM '*)
                                      (CDR X))
                                     (T (PROG1 [COND
                                                  [[FIXP (SETQ M (CAR (SETQ X (CDR X]
                                                   (LIST M (CAR (SETQ X (CDR X]
                                                  (T (SETQ M (SELECTQ (CAR X)
                                                                 ((FIXP FULLXPOINTER) 
                                                                      (OR (EVENP I WORDSPERCELL)
                                                                          (ERROR 
                                                                           "Record field not aligned"
                                                                                 (CONS NAM X)))
                                                                      2)
                                                                 (WORD 1)
                                                                 (SHOULDNT)))
                                                     (LIST (CAR X]
                                            [COND
                                               ((CADDR X)
                                                (SETQ PTRS (CONS (LIST (PACK* NAM 'PTR)
                                                                       `(\ADDBASE DATUM %, I))
                                                                 PTRS]
                                            (add I M))]
             %,.
             [AND PTRS `((ACCESSFNS %, NAME %, PTRS]
             (CREATE (\ALLOCBLOCK %, (FOLDHI I WORDSPERCELL])
+)
+
+
+
+(* ;; "When you change the SYSOUT's layout in this file, you must also")
+
+
+
+
+(* ;; "   Recreate RDSYS in the library, using (DORENAME 'R)")
+
+
+
+
+(* ;; "   Recompile DLFIXINIT and anything else that uses the constants defined here.")
+
+
+
+
+(* ;; "   Recompile LLFAULT. recompile VMEM")
+
+(DECLARE%: DONTCOPY 
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ WINDFLG T)
+
+
+(CONSTANTS (WINDFLG T))
+)
+
+(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 10Q)
+                          (\CHARACTERP 11Q)
+                          (\VMEMPAGEP 12Q NIL VMemPagePType)
+                          (\STREAM 13Q NIL STREAMTYPE)
+                          
+                          (* ;; "TYPE TABLE CONSTANTS - - - - - - - - - - - - - - - - - - - - - -")
+
+                          (\TT.TYPEMASK 3777Q TTTypeMask T)
+                          (\TT.NOREF 100000Q NIL T)
+                          (\TT.SYMBOLP 40000Q NIL T)
+                          (\TT.FIXP 20000Q)
+                          (\TT.NUMBERP 10000Q)
+                          (\TT.ATOM 4000Q)
+                          
+                          (* ;; 
+             "page map - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -")
+
+                          (\PMblockSize 40Q PMBLOCKSIZE)
+                          (\STATSsize 10Q T)
+                          (\NumPMTpages 10Q)
+                          (\EmptyPMTEntry 177777Q T)
+                          (\FirstVmemBlock 2 T)
+                          (\MAXVMPAGE 377775Q)
+                          (\MAXVMSEGMENT 377Q)
+                          
+                          (* ;; "interface page")
+
+                          (\IFPValidKey 12743Q T)
+                          
+                          (* ;; "MDS")
+
+                          (\FirstMDSPage 77776Q) (* ; "Was 37776Q pre 16-meg intiial")
+                          (\MaxMDSPage 1777775Q)
+                          (\DefaultSecondMDSPage 177774Q)
+                          (\MDSIncrement 1000Q)
+                          (\PagesPerMDSUnit 2)
+                                                             (* ; 
+                                                           "(FOLDLO \MDSIncrement WORDSPERPAGE)")
+                          
+                          (* ;; "arrays")
+
+                          (\ARRAYSPACE (56Q 0))
+                          (\FirstArraySegment 56Q)
+                          (\FirstArrayPage 27000Q)
+                          (\ARRAYSPACE2 (100Q 0))
+                          (\DefaultSecondArrayPage 100000Q) (* ; "Was 40000Q before 16meg initial")
+                          
+                          (* ;; "stack block constants")
+
+                          (\StackMask 160000Q T T)
+                          (\FxtnBlock 140000Q T T)
+                          (\GuardBlock 160000Q T T)
+                          (\BFBlock 100000Q T T)
+                          (\FreeStackBlock 120000Q T T)
+                          (\NotStackBlock 0)
+                                                             (* ; "none of the above")
+                          (\MinExtraStackWords 40Q T T)
+                          
+                          (* ;; "backspace kludge")
+
+                          (ERASECHARCODE 0 T)
+                          
+                          (* ;; "GC constants")
+
+                          (\HT1CNT 2000Q NIL T)
+                          (\HTSTKBIT 1000Q NIL T)
+                          (\HTCNTMASK 176000Q NIL T)
+                          (\HTMAINSIZE 200000Q NIL T)
+                          (\HTCOLLSIZE 4000000Q NIL T)
+                                                             (* ; "HTCOLL size in words")
+                          (\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 (25Q 0)
+                                 (AHTspace AHTbase))
+                          (\AtomHTpages 400Q AHTSIZE)
+                          (\LastAtomPage 377Q)
+                          (\MaxAtomFrLst 177777Q)
+                          (\SMALLPOSPSPACE (16Q 0))
+                          (\SmallPosHi 16Q SMALLPOSspace smallpl)
+                          (\SMALLNEGSPACE (17Q 0))
+                          (\SmallNegHi 17Q SMALLNEGspace smallneg)
+                          (\NumSmallPages 1000Q)
+                          
+                          (* ;; "PNAME SPACEin the old world; used for initial atoms now.")
+
+                          (\PNPSPACE (10Q 0)
+                                 (PNPspace PNPbase))
+                          (\PNAME.HI 10Q)
+                          (\OLDATOMSPACE (54Q 0))
+                                                             (* ; "NEW ATOM SPACE")
+                          (\ATOM.HI 54Q)
+                                                             (* ; "HI PART OF NEW ATOM SPACE")
+                          
+                          (* ;; "Definitions in old atom world")
+
+                          (\DEFSPACE (12Q 0)
+                                 (DEFspace DEFbase)
+                                 (DEFspace DEFbase))
+                          (\DEF.HI 12Q)
+                          (\VALSPACE (14Q 0)
+                                 (TOPVALspace TOPVALbase)
+                                 (VALspace VALbase))
+                          (\VAL.HI 14Q)
+                          (\PLISTSPACE (2 0)
+                                 (PLISTspace PLISTbase))
+                          (\PLIST.HI 2)
+                          (\PAGEMAP (5 0)
+                                 (PAGEMAPspace PAGEMAPbase))
+                          (\NumPageMapPages 400Q)
+                          (\PageMapTBL (24Q 1000Q)
+                                 (PMTspace PMTbase))
+                          (\InterfacePage (24Q 0)
+                                 (INTERFACEspace INTERFACEbase)
+                                 (INTERFACEspace INTERFACEbase))
+                          (\IOPAGE (0 177400Q))
+                          (\DoveIORegion (0 40000Q))
+                          (\IOCBPAGE (0 400Q))
+                          (\FPTOVP (2 0))
+                          (\MDSTypeTable (30Q 0)
+                                 (MDSTYPEspace MDSTYPEbase)
+                                 (MDSTYPEspace MDSTYPEbase))
+                          (\MDSTTsize 2000Q T)
+                                                             (* ; "in Pages")
+                          (\MISCSTATS (24Q 5000Q)
+                                 (STATSspace MISCSTATSbase))
+                          (\UFNTable (24Q 6000Q)
+                                 NIL
+                                 (STATSspace UFNTablebase))
+                          (\UFNTableSize 2)
+                          (\DTDSpaceBase (24Q 10000Q)
+                                 (DTDspace DTDbase)
+                                 (DTDspace DTDbase))
+                          (\DTDSize 22Q T)
+                          (\LISTPDTD (24Q 10132Q))
+                          (\EndTypeNumber 3777Q)
+                          (\LOCKEDPAGETABLE (24Q 70000Q))
+                          (\NumLPTPages 20Q)
+                          (\STACKSPACE (1 0)
+                                 (STACKspace NIL)
+                                 (STACKspace NIL))
+                          (\GuardStackAddr 170000Q)
+                          (\LastStackAddr 177776Q)
+                          (\STACKHI 1 T T)
+                          (\HTMAIN (26Q 0)
+                                 (HTMAINspace HTMAINbase)
+                                 (HTMAINspace HTMAINbase))
+                          (\HTMAINnpages 400Q T)
+                          (\HTOVERFLOW (27Q 0)
+                                 NIL
+                                 (NIL HTOVERFLOWbase))
+                          (\HTBIGCOUNT (27Q 100000Q))
+                          (\HTCOLL (34Q 0)
+                                 NIL
+                                 (HTCOLLspace HTCOLLbase))
+                          (\DISPLAYREGION (22Q 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 16Q T T)
+                          (\TeleRaidFXP 30Q T T)
+                          
+                          (* ;; "emulator segment locations")
+
+                          (DCB.EM 420Q)
+                          (DISPINTERRUPT.EM 421Q)
+                          (CURSORBITMAP.EM 431Q)
+                          (KBDAD0.EM 177034Q)
+                          (KBDAD1.EM 177035Q)
+                          (KBDAD2.EM 177036Q)
+                          (KBDAD3.EM 177037Q)
+                          (UTILIN.EM 177030Q)
+                          (CURSORX.EM 426Q)
+                          (CURSORY.EM 427Q)
+                          (MOUSEX.EM 424Q)
+                          (MOUSEY.EM 425Q)
+                          (\LispKeyMask 20000Q T T)
+                          (\BcplKeyMask 10400Q T T)
+                                                             (* ; "Machine types")
+                          (\MAIKO 3)
+                          (\DOLPHIN 4)
+                          (\DORADO 5)
+                          (\DANDELION 6)
+                          (\DAYBREAK 10Q)
+                          
+                          (* ;; "FOR DLION (AND DAYBREAK)")
+
+                          (\VP.DISPLAY 11000Q)
+                          (\NP.DISPLAY 312Q)
+                                                             (* ; 
+                           "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)")
+                          (\NP.WIDEDOVEDISPLAY 363Q)
+                                                             (* ; 
+                                                           "Wide Dove display 1152x864 pixels")
+                          (\WIDEDOVEDISPLAYWIDTH 2200Q)
+                          (\RP.AFTERDISPLAY 316Q)
+                                                             (* ; "Includes 4 pages for cursor")
+                          (\RP.AFTERDOVEDISPLAY 363Q)
+                                                             (* ; "if big screen")
+                          (\RP.DISPLAY 0)
+                          (\RP.TEMPDISPLAY 5001Q)
+                          (\RP.MISCLOCKED 5364Q)
+                                                             (* ; 
+                                                          "(+ \RP.TEMPDISPLAY \NP.WIDEDOVEDISPLAY)")
+                          (\RP.STACK 1400Q)
+                          (\VP.STACK 400Q)
+                          (\RP.MAP 400Q)
+                          (\NP.MAP 400Q)
+                          (\RP.IOPAGE 1000Q)
+                                                             (* ; 
+                          "The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range")
+                          (\RP.DOVEIOCBPAGE 1037Q)
+                          (\RP.DOVEIORGN 1040Q)
+                          (\VP.DOVEIORGN 100Q)
+                          (\DOVEIORGNSIZE 100Q)
+                          (\VP.IOPAGE 377Q)
+                          (\VP.IFPAGE 12000Q)
+                          (\VP.FPTOVP 1000Q)
+                          (\NP.FPTOVP 10000Q)
+                          (\RP.FPTOVP 2000Q)
+                          (\RP.STARTBUFFERS 1200Q)
+                          (\VP.TYPETABLE 14000Q)
+                          (\NP.TYPETABLE 2000Q)
+                          (\RP.TYPETABLE 12000Q)
+                          (\VP.GCTABLE 13000Q)
+                          (\NP.GCTABLE 400Q)
+                          (\RP.GCTABLE 14000Q)
+                          (\VP.GCOVERFLOW 13400Q)
+                          (\NP.GCOVERFLOW 1)
+                          (\RP.GCOVERFLOW 14400Q)
+                          (\FP.IFPAGE 2)
+                          (\VP.IOCBS 1)
+                          (\VP.PRIMARYMAP 12002Q)
+                          (\VP.SECONDARYMAP 2400Q)
+                          (\VP.LPT 12160Q)
+                          (\VP.INITSCRATCH 10Q)
+                          (\VP.RPT 200Q)
+                          (\VP.BUFFERS 332Q)
+                                                             (* ; "DLion processor commands")
+                          (\DL.PROCESSORBUSY 100000Q)
+                          (\DL.SETTOD 100001Q)
+                          (\DL.READTOD 100002Q)
+                          (\DL.READPID 100003Q)
+                          (\DL.BOOTBUTTON 100004Q)))
+
+(RPAQQ MISCSTATSLAYOUT ((STARTTIME FIXP MSstrtTime)
+                            (TOTALTIME FIXP)
+                            (SWAPWAITTIME FIXP T)
+                            (PAGEFAULTS FIXP T)
+                            (SWAPWRITES FIXP T)
+                            (DISKIOTIME FIXP T)
+                            (DISKOPS FIXP T)
+                            (KEYBOARDWAITTIME FIXP T)
+                            (GCTIME FIXP T)
+                            (NETIOTIME FIXP T)
+                            (NETIOOPS FIXP T)
+                            (SWAPTEMP0 FIXP)
+                            (SWAPTEMP1 FIXP)
+                            (RCLKSECOND FIXP)
+                            (SECONDSCLOCK FIXP)
+                            (MILLISECONDSCLOCK FIXP)
+                            (BASECLOCK FIXP)
+                            (RCLKTEMP0 FIXP)
+                            (SECONDSTMP FIXP)
+                            (MILLISECONDSTMP FIXP)
+                            (BASETMP FIXP)
+                            (EXCESSTIMETMP FIXP)
+                            (CLOCKTEMP0 FIXP)
+                            (DISKTEMP0 FIXP)
+                            (DISKTEMP1 FIXP)
+                            (TELERAIDTEMP1 FIXP)
+                            (TELERAIDTEMP2 FIXP)
+                            (TELERAIDTEMP3 FIXP)
+                            (LASTUSERACTION FIXP)
+                            (DLMOUSETIMER FIXP)
+                            (DLMOUSETEMP FIXP)))
+
+(RPAQQ IFPAGELAYOUT ((CurrentFXP WORD)
+                                                             (* ; 
+                                      "First 7 items are FX values for user and 6 system contexts.")
+                         (ResetFXP WORD)
+                         (SubovFXP WORD)
+                         (KbdFXP WORD)
+                         (HardReturnFXP WORD)
+                         (GCFXP WORD)
+                         (FAULTFXP WORD)
+                         (EndOfStack WORD)
+                                                             (* ; 
+                            "Stack high-water mark: address of guard block at current end of stack")
+                         (LVersion WORD)
+                                                             (* ; 
+           "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp")
+                         (MinRVersion WORD)
+                         (MinBVersion WORD)
+                         (RVersion WORD)
+                                                             (* ; 
+                                               "Bcpl fills in the actual microcode, Bcpl versions.")
+                         (BVersion WORD)
+                         (MachineType WORD)
+                         (MiscFXP WORD)
+                                                             (* ; "FX for MISC context")
+                         (Key WORD)
+                                                             (* ; 
+                                                           "= IFPValidKey if vmem consistent.")
+                         (SerialNumber WORD)
+                                                             (* ; 
+                                                           "Pup host number (Dorado/Dolphin)")
+                         (EmulatorSpace WORD)
+                                                             (* ; 
+                                                           "Hiloc of bcpl space (always zero now)")
+                         (ScreenWidth WORD)
+                         (NxtPMAddr WORD)
+                                                             (* ; 
+                                            "Next page to be allocated in secondary page map table")
+                         (NActivePages WORD)
+                                                             (* ; "Length of vmem in use")
+                         (NDirtyPages WORD)
+                                                             (* ; 
+                                                       "not used, but maintained as = NActivePages")
+                         (filePnPMP0 WORD)
+                                                             (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live")
+                         (filePnPMT0 WORD)
+                                                             (* ; 
+                                       "Sysout page number of first page of primary page map table")
+                         (TELERAIDFXP WORD)
+                                                             (* ; "FX for TeleRaid server context")
+                         (NATIVE-START-MEM-PAGE WORD)
+                                                             (* ; 
+                                                           "Unix page where native code starts")
+                         (NATIVE-LENGTH-PAGE WORD)
+                                                             (* ; "Unix page length of native code")
+                         (NATIVE-PAGE-OFFSET WORD)
+                                                             (* ; 
+                                                           "Lisp Disk Page offset  of native code")
+                         (UserNameAddr WORD)
+                                                             (* ; 
+                                 "Addresses in bcpl space (seg 0) of global user name and password")
+                         (UserPswdAddr WORD)
+                         (StackBase WORD)
+                                                             (* ; 
+                                                           "Stack address where user stack starts")
+                         (FAULTHI WORD)
+                                                             (* ; 
+         "Microcode for page fault stores fault address here, then does context switch to FAULTFXP")
+                         (FAULTLO WORD)
+                         (DEVCONFIG WORD)
+                                                             (* ; "IT'S FOR KB,DISP TYPE")
+                                                             (* ; 
+                                   "Formerly REALPAGETABLE, back when it was always in Bcpl space.")
+                         (RPTSIZE WORD)
+                                                             (* ; 
+                                                           "Number of entries in Real Page Table")
+                         (RPOFFSET WORD)
+                                                             (* ; "RP-RPOFFSET => index in table")
+                         (MAXETHERBYTES WORD)
+                                                             (* ; 
+                          "Number of bytes available in a pbi, not counting encapsulation (Dorado)")
+                         (EMBUFVP WORD)
+                                                             (* ; 
+                                                           "VP of a one-page emulator buffer")
+                         (NSHost0 WORD)
+                                                             (* ; "Machine's 48-bit NS host number.  Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in.")
+                         (NSHost1 WORD)
+                         (NSHost2 WORD)
+                         (MDSZone WORD)
+                                                             (* ; 
+                                               "Obsolete -- was used by Dolphin 10MB network code.")
+                         (MDSZoneLength WORD)
+                         (EMUBUFFERS WORD)
+                                                             (* ; 
+                                             "Buffer space in segment 0 for swapping/disk activity")
+                         (EMUBUFLENGTH WORD)
+                                                             (* ; "Number of words of said space")
+                         (LASTNUMCHARS WORD)
+                                                             (* ; "No longer used?")
+                         (SYSDISK WORD)
+                                                             (* ; 
+                                 "Address of sysDisk in Bcpl space -- disk obj for boot partition.")
+                         (ISFMAP WORD)
+                         
+                         (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!")
+
+                         (MISCSTACKFN FULLXPOINTER)
+                         (MISCSTACKARG1 FULLXPOINTER)
+                         (MISCSTACKARG2 FULLXPOINTER)
+                         (MISCSTACKRESULT FULLXPOINTER)
+                         (NRealPages WORD)
+                                                             (* ; "Number pages of real memory")
+                         (LastLockedFilePage WORD)
+                                                             (* ; 
+                         "Last page of vmem that is locked--booting has to load at least that far.")
+                         (LastDominoFilePage WORD)
+                                                             (* ; 
+                                                "Last sysout page reserved for Dandelion microcode")
+                         (FPTOVPStart WORD)
+                                                             (* ; "Sysout page where FPTOVP starts")
+                         (FAKEMOUSEBITS WORD)
+                                                             (* ; 
+                                      "Used to implement fake middle button on 2-button Dandelion.")
+                         (DL24BitAddressable WORD)
+                                                             (* ; 
+                                      "non-zero if DLion capable of addressing 32MB virtual memory")
+                         (REALPAGETABLEPTR FULLXPOINTER)
+                                                             (* ; 
+                            "Address of real page table, set up by Bcpl (but not chained together)")
+                         (DLLastVmemPage WORD)
+                                                             (* ; 
+                                           "DLion booting microcode puts length of vmem file here.")
+                         (FullSpaceUsed WORD)
+                                                             (* ; 
+                                          "Non-zero if vmem beyond initial 8MB has been allocated.")
+                         (FAKEKBDAD4 WORD)
+                         (FAKEKBDAD5 WORD)
+                         
+                         (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with.")
+
+                         (XVmemFmapBase WORD)
+                                                             (* ; 
+ "Bcpl stores isf map pointer to each partition here.  First is redundant with ISFMAP field above.")
+                         (NIL WORD)
+                         (NIL WORD)
+                         (XVmemFmapHighBase WORD)
+                                                             (* ; 
+                          "Bcpl stores the highest vm page contained in this or earlier partition.")
+                         (NIL WORD)
+                         (NIL WORD)
+                         (XVmemDiskBase FULLXPOINTER)
+                                                             (* ; 
+      "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).")
+                         (NIL FULLXPOINTER)
+                         (NIL FULLXPOINTER)))
+
+(RPAQQ MAIKO.IFPAGELAYOUT ((CurrentFXP WORD)
+                                                             (* ; 
+                                      "First 7 items are FX values for user and 6 system contexts.")
+                               (ResetFXP WORD)
+                               (SubovFXP WORD)
+                               (KbdFXP WORD)
+                               (HardReturnFXP WORD)
+                               (GCFXP WORD)
+                               (FAULTFXP WORD)
+                               (EndOfStack WORD)
+                                                             (* ; 
+                            "Stack high-water mark: address of guard block at current end of stack")
+                               (LVersion WORD)
+                                                             (* ; 
+           "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp")
+                               (MinRVersion WORD)
+                               (MinBVersion WORD)
+                               (RVersion WORD)
+                                                             (* ; 
+                                               "Bcpl fills in the actual microcode, Bcpl versions.")
+                               (BVersion WORD)
+                               (MachineType WORD)
+                               (MiscFXP WORD)
+                                                             (* ; "FX for MISC context")
+                               (Key WORD)
+                                                             (* ; 
+                                                           "= IFPValidKey if vmem consistent.")
+                               (SerialNumber WORD)
+                                                             (* ; 
+                                                           "Pup host number (Dorado/Dolphin)")
+                               (EmulatorSpace WORD)
+                                                             (* ; 
+                                                           "Hiloc of bcpl space (always zero now)")
+                               (ScreenWidth WORD)
+                               (NxtPMAddr WORD)
+                                                             (* ; 
+                                            "Next page to be allocated in secondary page map table")
+                               (NIL WORD)
+                                                             (* ; 
+                                                          "WAS NActivePages, Length of vmem in use")
+                               (NIL WORD)
+                                                             (* ; 
+                                      "WAS NDirtyPages, not used, but maintained as = NActivePages")
+                               (filePnPMP0 WORD)
+                                                             (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live")
+                               (filePnPMT0 WORD)
+                                                             (* ; 
+                                       "Sysout page number of first page of primary page map table")
+                               (TELERAIDFXP WORD)
+                                                             (* ; "FX for TeleRaid server context")
+                               (NATIVE-START-MEM-PAGE WORD)
+                                                             (* ; 
+                                                           "Unix page where native code starts")
+                               (NATIVE-LENGTH-PAGE WORD)
+                                                             (* ; "Unix page length of native code")
+                               (NATIVE-PAGE-OFFSET WORD)
+                                                             (* ; 
+                                                           "Lisp Disk Page offset  of native code")
+                               (UserNameAddr WORD)
+                                                             (* ; 
+                                 "Addresses in bcpl space (seg 0) of global user name and password")
+                               (UserPswdAddr WORD)
+                               (StackBase WORD)
+                                                             (* ; 
+                                                           "Stack address where user stack starts")
+                               (FAULTHI WORD)
+                                                             (* ; 
+         "Microcode for page fault stores fault address here, then does context switch to FAULTFXP")
+                               (FAULTLO WORD)
+                               (DEVCONFIG WORD)
+                                                             (* ; "IT'S FOR KB,DISP TYPE")
+                                                             (* ; 
+                                   "Formerly REALPAGETABLE, back when it was always in Bcpl space.")
+                               (RPTSIZE WORD)
+                                                             (* ; 
+                                                           "Number of entries in Real Page Table")
+                               (RPOFFSET WORD)
+                                                             (* ; "RP-RPOFFSET => index in table")
+                               (MAXETHERBYTES WORD)
+                                                             (* ; 
+                          "Number of bytes available in a pbi, not counting encapsulation (Dorado)")
+                               (EMBUFVP WORD)
+                                                             (* ; 
+                                                           "VP of a one-page emulator buffer")
+                               (NSHost0 WORD)
+                                                             (* ; "Machine's 48-bit NS host number.  Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in.")
+                               (NSHost1 WORD)
+                               (NSHost2 WORD)
+                               (MDSZone WORD)
+                                                             (* ; 
+                                               "Obsolete -- was used by Dolphin 10MB network code.")
+                               (MDSZoneLength WORD)
+                               (EMUBUFFERS WORD)
+                                                             (* ; 
+                                             "Buffer space in segment 0 for swapping/disk activity")
+                               (EMUBUFLENGTH WORD)
+                                                             (* ; "Number of words of said space")
+                               
+                               (* ;; 
+                             "The following 2 are available if NEW_STOARGE is specified in C")
+
+                               (ProcessSize WORD)
+                                                             (* ; 
+                                                  "Process size for which can be use as LISP space")
+                               (StorageFullState WORD)
+                                                             (* ; "Save last storage state")
+                               (ISFMAP WORD)
+                               
+                               (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!")
+
+                               (MISCSTACKFN FULLXPOINTER)
+                               (MISCSTACKARG1 FULLXPOINTER)
+                               (MISCSTACKARG2 FULLXPOINTER)
+                               (MISCSTACKRESULT FULLXPOINTER)
+                               (NRealPages WORD)
+                                                             (* ; "Number pages of real memory")
+                               (LastLockedFilePage WORD)
+                                                             (* ; 
+                         "Last page of vmem that is locked--booting has to load at least that far.")
+                               (LastDominoFilePage WORD)
+                                                             (* ; 
+                                                "Last sysout page reserved for Dandelion microcode")
+                               (FPTOVPStart WORD)
+                                                             (* ; "Sysout page where FPTOVP starts")
+                               (FAKEMOUSEBITS WORD)
+                                                             (* ; 
+                                      "Used to implement fake middle button on 2-button Dandelion.")
+                               (DL24BitAddressable WORD)
+                                                             (* ; 
+                                      "non-zero if DLion capable of addressing 32MB virtual memory")
+                               (REALPAGETABLEPTR FULLXPOINTER)
+                                                             (* ; 
+                            "Address of real page table, set up by Bcpl (but not chained together)")
+                               (SYSDISK WORD)
+                                                             (* ; 
+                       "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.")
+                               (FullSpaceUsed WORD)
+                                                             (* ; 
+                                          "Non-zero if vmem beyond initial 8MB has been allocated.")
+                               (FAKEKBDAD4 WORD)
+                               (FAKEKBDAD5 WORD)
+                               
+                               (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with.")
+
+                               (XVmemFmapBase WORD)
+                                                             (* ; 
+ "Bcpl stores isf map pointer to each partition here.  First is redundant with ISFMAP field above.")
+                               (NIL WORD)
+                               (NIL WORD)
+                               (XVmemFmapHighBase WORD)
+                                                             (* ; 
+                          "Bcpl stores the highest vm page contained in this or earlier partition.")
+                               (NIL WORD)
+                               (NIL WORD)
+                               (XVmemDiskBase FULLXPOINTER)
+                                                             (* ; 
+      "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).")
+                               (NIL FULLXPOINTER)
+                               (NIL FULLXPOINTER)
+                               (DLLastVmemPage FIXP)
+                                                             (* ; 
+                                           "DLion booting microcode puts length of vmem file here.")
+                               (NActivePages FIXP)
+                                                             (* ; "Length of vmem in use")
+                               (NDirtyPages FIXP)
+                                                             (* ; 
+                                                       "not used, but maintained as = NActivePages")
+                               ))
+
+(RPAQQ IOPAGELAYOUT ((NIL 22Q WORD)
+                         (DLMAINTPANEL WORD NIL T)
+                         (DLFLOPPYCMD WORD)
+                         (DLTTYPORTCMD WORD)
+                         (DLPROCESSORCMD WORD)
+                         (NEWMOUSESTATE WORD)
+                         (DLBEEPCMD WORD)
+                         (DLRS232CMISCCOMMAND WORD)
+                         (DLRS232CPUTFLAG WORD)
+                         (DLRS232CGETFLAG WORD)
+                         (NIL 6 WORD)
+                         (DLFLOPPY WORD)
+                         (DLTTYOUT WORD)
+                         (NIL 1 WORD)
+                         (DLTTYIN WORD)
+                         (NIL 1 WORD)
+                         (DLPROCESSOR2 WORD)
+                         (DLPROCESSOR1 WORD)
+                         (DLPROCESSOR0 WORD)
+                         (NEWMOUSEX WORD)
+                         (NEWMOUSEY WORD)
+                         (DLBEEPFREQ WORD)
+                         (DLRS232CPARAMETERCSBLO WORD)
+                         (DLRS232CPARAMETERCSBHI WORD)
+                         (DLRS232CSETRS366STATUS 3 WORD)
+                         (DLRS232CPUTCSBLO WORD)
+                         (DLRS232CPUTCSBHI WORD)
+                         (DLRS232CGETCSBLO WORD)
+                         (DLRS232CGETCSBHI WORD)
+                         (DLRS232CDEVICESTATUS WORD)
+                         (DLRS232CPARAMETEROUTCOME WORD)
+                         (DLTODVALID WORD)
+                         (DLTODLO WORD NIL T)
+                         (DLTODHI WORD)
+                         (DLTODLO2 WORD)
+                         (DLMOUSEX WORD NIL T)
+                         (DLMOUSEY WORD NIL T)
+                         (DLUTILIN WORD NIL T)
+                         (DLKBDAD0 WORD NIL T)
+                         (DLKBDAD1 WORD NIL T)
+                         (DLKBDAD2 WORD NIL T)
+                         (DLKBDAD3 WORD NIL T)
+                         (DLKBDAD4 WORD NIL T)
+                         (DLKBDAD5 WORD NIL T)
+                         (DLLSEPIMAGECSB 40Q WORD)
+                         (DLIOPHARDWARECONFIG WORD)
+                         (NIL 13Q WORD)
+                         (DLRS232CPARAMETERCSBLO.11 WORD)
+                         (DLRS232CPARAMETERCSBHI.11 WORD)
+                         (DLRS232CSETRS366STATUS.11 16Q WORD)
+                         (NIL 74Q WORD)
+                         (DLMAGTAPE 4 WORD)
+                         (DLETHERNET 14Q WORD NIL T)
+                         (NIL 37Q WORD)
+                         (DLDISPINTERRUPT WORD NIL T)
+                         (DLDISPCONTROL WORD)
+                         (DLDISPBORDER WORD)
+                         (DLCURSORX WORD NIL T)
+                         (DLCURSORY WORD NIL T)
+                         (DLCURSORBITMAP 20Q WORD NIL T)))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ CDRCODING 1)
+
+(RPAQQ \SMALLP 1)
+
+(RPAQQ \FIXP 2)
+
+(RPAQQ \FLOATP 3)
+
+(RPAQQ \LITATOM 4)
+
+(RPAQQ \LISTP 5)
+
+(RPAQQ \ARRAYP 6)
+
+(RPAQQ \STRINGP 7)
+
+(RPAQQ \STACKP 10Q)
+
+(RPAQQ \CHARACTERP 11Q)
+
+(RPAQQ \VMEMPAGEP 12Q)
+
+(RPAQQ \STREAM 13Q)
+
+(RPAQQ \TT.TYPEMASK 3777Q)
+
+(RPAQQ \TT.NOREF 100000Q)
+
+(RPAQQ \TT.SYMBOLP 40000Q)
+
+(RPAQQ \TT.FIXP 20000Q)
+
+(RPAQQ \TT.NUMBERP 10000Q)
+
+(RPAQQ \TT.ATOM 4000Q)
+
+(RPAQQ \PMblockSize 40Q)
+
+(RPAQQ \STATSsize 10Q)
+
+(RPAQQ \NumPMTpages 10Q)
+
+(RPAQQ \EmptyPMTEntry 177777Q)
+
+(RPAQQ \FirstVmemBlock 2)
+
+(RPAQQ \MAXVMPAGE 377775Q)
+
+(RPAQQ \MAXVMSEGMENT 377Q)
+
+(RPAQQ \IFPValidKey 12743Q)
+
+(RPAQQ \FirstMDSPage 77776Q)
+
+(RPAQQ \MaxMDSPage 1777775Q)
+
+(RPAQQ \DefaultSecondMDSPage 177774Q)
+
+(RPAQQ \MDSIncrement 1000Q)
+
+(RPAQQ \PagesPerMDSUnit 2)
+
+(RPAQQ \FirstArraySegment 56Q)
+
+(RPAQQ \FirstArrayPage 27000Q)
+
+(RPAQQ \DefaultSecondArrayPage 100000Q)
+
+(RPAQQ \StackMask 160000Q)
+
+(RPAQQ \FxtnBlock 140000Q)
+
+(RPAQQ \GuardBlock 160000Q)
+
+(RPAQQ \BFBlock 100000Q)
+
+(RPAQQ \FreeStackBlock 120000Q)
+
+(RPAQQ \NotStackBlock 0)
+
+(RPAQQ \MinExtraStackWords 40Q)
+
+(RPAQQ ERASECHARCODE 0)
+
+(RPAQQ \HT1CNT 2000Q)
+
+(RPAQQ \HTSTKBIT 1000Q)
+
+(RPAQQ \HTCNTMASK 176000Q)
+
+(RPAQQ \HTMAINSIZE 200000Q)
+
+(RPAQQ \HTCOLLSIZE 4000000Q)
+
+(RPAQQ \HTENDFREE 1)
+
+(RPAQQ \HTFREEPTR 0)
+
+(RPAQQ \AtomHI 0)
+
+(RPAQQ \CHARHI 7)
+
+(RPAQQ \AtomHTpages 400Q)
+
+(RPAQQ \LastAtomPage 377Q)
+
+(RPAQQ \MaxAtomFrLst 177777Q)
+
+(RPAQQ \SmallPosHi 16Q)
+
+(RPAQQ \SmallNegHi 17Q)
+
+(RPAQQ \NumSmallPages 1000Q)
+
+(RPAQQ \PNAME.HI 10Q)
+
+(RPAQQ \ATOM.HI 54Q)
+
+(RPAQQ \DEF.HI 12Q)
+
+(RPAQQ \VAL.HI 14Q)
+
+(RPAQQ \PLIST.HI 2)
+
+(RPAQQ \NumPageMapPages 400Q)
+
+(RPAQQ \MDSTTsize 2000Q)
+
+(RPAQQ \UFNTableSize 2)
+
+(RPAQQ \DTDSize 22Q)
+
+(RPAQQ \EndTypeNumber 3777Q)
+
+(RPAQQ \NumLPTPages 20Q)
+
+(RPAQQ \GuardStackAddr 170000Q)
+
+(RPAQQ \LastStackAddr 177776Q)
+
+(RPAQQ \STACKHI 1)
+
+(RPAQQ \HTMAINnpages 400Q)
+
+(RPAQQ \D1BCPLspace 0)
+
+(RPAQQ \D0BCPLspace 0)
+
+(RPAQQ \CurrentFXP 0)
+
+(RPAQQ \ResetFXP 1)
+
+(RPAQQ \SubovFXP 2)
+
+(RPAQQ \KbdFXP 3)
+
+(RPAQQ \HardReturnFXP 4)
+
+(RPAQQ \GCFXP 5)
+
+(RPAQQ \FAULTFXP 6)
+
+(RPAQQ \MiscFXP 16Q)
+
+(RPAQQ \TeleRaidFXP 30Q)
+
+(RPAQQ DCB.EM 420Q)
+
+(RPAQQ DISPINTERRUPT.EM 421Q)
+
+(RPAQQ CURSORBITMAP.EM 431Q)
+
+(RPAQQ KBDAD0.EM 177034Q)
+
+(RPAQQ KBDAD1.EM 177035Q)
+
+(RPAQQ KBDAD2.EM 177036Q)
+
+(RPAQQ KBDAD3.EM 177037Q)
+
+(RPAQQ UTILIN.EM 177030Q)
+
+(RPAQQ CURSORX.EM 426Q)
+
+(RPAQQ CURSORY.EM 427Q)
+
+(RPAQQ MOUSEX.EM 424Q)
+
+(RPAQQ MOUSEY.EM 425Q)
+
+(RPAQQ \LispKeyMask 20000Q)
+
+(RPAQQ \BcplKeyMask 10400Q)
+
+(RPAQQ \MAIKO 3)
+
+(RPAQQ \DOLPHIN 4)
+
+(RPAQQ \DORADO 5)
+
+(RPAQQ \DANDELION 6)
+
+(RPAQQ \DAYBREAK 10Q)
+
+(RPAQQ \VP.DISPLAY 11000Q)
+
+(RPAQQ \NP.DISPLAY 312Q)
+
+(RPAQQ \NP.WIDEDOVEDISPLAY 363Q)
+
+(RPAQQ \WIDEDOVEDISPLAYWIDTH 2200Q)
+
+(RPAQQ \RP.AFTERDISPLAY 316Q)
+
+(RPAQQ \RP.AFTERDOVEDISPLAY 363Q)
+
+(RPAQQ \RP.DISPLAY 0)
+
+(RPAQQ \RP.TEMPDISPLAY 5001Q)
+
+(RPAQQ \RP.MISCLOCKED 5364Q)
+
+(RPAQQ \RP.STACK 1400Q)
+
+(RPAQQ \VP.STACK 400Q)
+
+(RPAQQ \RP.MAP 400Q)
+
+(RPAQQ \NP.MAP 400Q)
+
+(RPAQQ \RP.IOPAGE 1000Q)
+
+(RPAQQ \RP.DOVEIOCBPAGE 1037Q)
+
+(RPAQQ \RP.DOVEIORGN 1040Q)
+
+(RPAQQ \VP.DOVEIORGN 100Q)
+
+(RPAQQ \DOVEIORGNSIZE 100Q)
+
+(RPAQQ \VP.IOPAGE 377Q)
+
+(RPAQQ \VP.IFPAGE 12000Q)
+
+(RPAQQ \VP.FPTOVP 1000Q)
+
+(RPAQQ \NP.FPTOVP 10000Q)
+
+(RPAQQ \RP.FPTOVP 2000Q)
+
+(RPAQQ \RP.STARTBUFFERS 1200Q)
+
+(RPAQQ \VP.TYPETABLE 14000Q)
+
+(RPAQQ \NP.TYPETABLE 2000Q)
+
+(RPAQQ \RP.TYPETABLE 12000Q)
+
+(RPAQQ \VP.GCTABLE 13000Q)
+
+(RPAQQ \NP.GCTABLE 400Q)
+
+(RPAQQ \RP.GCTABLE 14000Q)
+
+(RPAQQ \VP.GCOVERFLOW 13400Q)
+
+(RPAQQ \NP.GCOVERFLOW 1)
+
+(RPAQQ \RP.GCOVERFLOW 14400Q)
+
+(RPAQQ \FP.IFPAGE 2)
+
+(RPAQQ \VP.IOCBS 1)
+
+(RPAQQ \VP.PRIMARYMAP 12002Q)
+
+(RPAQQ \VP.SECONDARYMAP 2400Q)
+
+(RPAQQ \VP.LPT 12160Q)
+
+(RPAQQ \VP.INITSCRATCH 10Q)
+
+(RPAQQ \VP.RPT 200Q)
+
+(RPAQQ \VP.BUFFERS 332Q)
+
+(RPAQQ \DL.PROCESSORBUSY 100000Q)
+
+(RPAQQ \DL.SETTOD 100001Q)
+
+(RPAQQ \DL.READTOD 100002Q)
+
+(RPAQQ \DL.READPID 100003Q)
+
+(RPAQQ \DL.BOOTBUTTON 100004Q)
+
+
+(CONSTANTS (CDRCODING 1)
+       (\SMALLP 1)
+       (\FIXP 2)
+       (\FLOATP 3)
+       (\LITATOM 4)
+       (\LISTP 5)
+       (\ARRAYP 6)
+       (\STRINGP 7)
+       (\STACKP 10Q)
+       (\CHARACTERP 11Q)
+       (\VMEMPAGEP 12Q)
+       (\STREAM 13Q)
+       (\TT.TYPEMASK 3777Q)
+       (\TT.NOREF 100000Q)
+       (\TT.SYMBOLP 40000Q)
+       (\TT.FIXP 20000Q)
+       (\TT.NUMBERP 10000Q)
+       (\TT.ATOM 4000Q)
+       (\PMblockSize 40Q)
+       (\STATSsize 10Q)
+       (\NumPMTpages 10Q)
+       (\EmptyPMTEntry 177777Q)
+       (\FirstVmemBlock 2)
+       (\MAXVMPAGE 377775Q)
+       (\MAXVMSEGMENT 377Q)
+       (\IFPValidKey 12743Q)
+       (\FirstMDSPage 77776Q)
+       (\MaxMDSPage 1777775Q)
+       (\DefaultSecondMDSPage 177774Q)
+       (\MDSIncrement 1000Q)
+       (\PagesPerMDSUnit 2)
+       (\FirstArraySegment 56Q)
+       (\FirstArrayPage 27000Q)
+       (\DefaultSecondArrayPage 100000Q)
+       (\StackMask 160000Q)
+       (\FxtnBlock 140000Q)
+       (\GuardBlock 160000Q)
+       (\BFBlock 100000Q)
+       (\FreeStackBlock 120000Q)
+       (\NotStackBlock 0)
+       (\MinExtraStackWords 40Q)
+       (ERASECHARCODE 0)
+       (\HT1CNT 2000Q)
+       (\HTSTKBIT 1000Q)
+       (\HTCNTMASK 176000Q)
+       (\HTMAINSIZE 200000Q)
+       (\HTCOLLSIZE 4000000Q)
+       (\HTENDFREE 1)
+       (\HTFREEPTR 0)
+       (\AtomHI 0)
+       (\CHARHI 7)
+       (\AtomHTpages 400Q)
+       (\LastAtomPage 377Q)
+       (\MaxAtomFrLst 177777Q)
+       (\SmallPosHi 16Q)
+       (\SmallNegHi 17Q)
+       (\NumSmallPages 1000Q)
+       (\PNAME.HI 10Q)
+       (\ATOM.HI 54Q)
+       (\DEF.HI 12Q)
+       (\VAL.HI 14Q)
+       (\PLIST.HI 2)
+       (\NumPageMapPages 400Q)
+       (\MDSTTsize 2000Q)
+       (\UFNTableSize 2)
+       (\DTDSize 22Q)
+       (\EndTypeNumber 3777Q)
+       (\NumLPTPages 20Q)
+       (\GuardStackAddr 170000Q)
+       (\LastStackAddr 177776Q)
+       (\STACKHI 1)
+       (\HTMAINnpages 400Q)
+       (\D1BCPLspace 0)
+       (\D0BCPLspace 0)
+       (\CurrentFXP 0)
+       (\ResetFXP 1)
+       (\SubovFXP 2)
+       (\KbdFXP 3)
+       (\HardReturnFXP 4)
+       (\GCFXP 5)
+       (\FAULTFXP 6)
+       (\MiscFXP 16Q)
+       (\TeleRaidFXP 30Q)
+       (DCB.EM 420Q)
+       (DISPINTERRUPT.EM 421Q)
+       (CURSORBITMAP.EM 431Q)
+       (KBDAD0.EM 177034Q)
+       (KBDAD1.EM 177035Q)
+       (KBDAD2.EM 177036Q)
+       (KBDAD3.EM 177037Q)
+       (UTILIN.EM 177030Q)
+       (CURSORX.EM 426Q)
+       (CURSORY.EM 427Q)
+       (MOUSEX.EM 424Q)
+       (MOUSEY.EM 425Q)
+       (\LispKeyMask 20000Q)
+       (\BcplKeyMask 10400Q)
+       (\MAIKO 3)
+       (\DOLPHIN 4)
+       (\DORADO 5)
+       (\DANDELION 6)
+       (\DAYBREAK 10Q)
+       (\VP.DISPLAY 11000Q)
+       (\NP.DISPLAY 312Q)
+       (\NP.WIDEDOVEDISPLAY 363Q)
+       (\WIDEDOVEDISPLAYWIDTH 2200Q)
+       (\RP.AFTERDISPLAY 316Q)
+       (\RP.AFTERDOVEDISPLAY 363Q)
+       (\RP.DISPLAY 0)
+       (\RP.TEMPDISPLAY 5001Q)
+       (\RP.MISCLOCKED 5364Q)
+       (\RP.STACK 1400Q)
+       (\VP.STACK 400Q)
+       (\RP.MAP 400Q)
+       (\NP.MAP 400Q)
+       (\RP.IOPAGE 1000Q)
+       (\RP.DOVEIOCBPAGE 1037Q)
+       (\RP.DOVEIORGN 1040Q)
+       (\VP.DOVEIORGN 100Q)
+       (\DOVEIORGNSIZE 100Q)
+       (\VP.IOPAGE 377Q)
+       (\VP.IFPAGE 12000Q)
+       (\VP.FPTOVP 1000Q)
+       (\NP.FPTOVP 10000Q)
+       (\RP.FPTOVP 2000Q)
+       (\RP.STARTBUFFERS 1200Q)
+       (\VP.TYPETABLE 14000Q)
+       (\NP.TYPETABLE 2000Q)
+       (\RP.TYPETABLE 12000Q)
+       (\VP.GCTABLE 13000Q)
+       (\NP.GCTABLE 400Q)
+       (\RP.GCTABLE 14000Q)
+       (\VP.GCOVERFLOW 13400Q)
+       (\NP.GCOVERFLOW 1)
+       (\RP.GCOVERFLOW 14400Q)
+       (\FP.IFPAGE 2)
+       (\VP.IOCBS 1)
+       (\VP.PRIMARYMAP 12002Q)
+       (\VP.SECONDARYMAP 2400Q)
+       (\VP.LPT 12160Q)
+       (\VP.INITSCRATCH 10Q)
+       (\VP.RPT 200Q)
+       (\VP.BUFFERS 332Q)
+       (\DL.PROCESSORBUSY 100000Q)
+       (\DL.SETTOD 100001Q)
+       (\DL.READTOD 100002Q)
+       (\DL.READPID 100003Q)
+       (\DL.BOOTBUTTON 100004Q))
+)
+
+(RPAQQ \MPERRORS ((\MP.OBSOLETEVMEM 1)
+                      (\MP.INVALIDVMEM 2 "Vmem inconsistent at startup")
+                      (\MP.IOCBPAGE 3 "No place for IOCB page at startup")
+                      (\MP.MOB 4 "Map out of bounds")
+                      (\MP.INVALIDADDR 5)
+                      (\MP.INVALIDVP 6)
+                      (\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain")
+                      (\MP.SELECTLOOP 10Q "Loop in \SELECTREALPAGE")
+                      (\MP.NEWPAGE 11Q "Attempt to allocate already existing page")
+                      (\MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page")
+                      (\MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another")
+                      (\MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box")
+                      (\MP.RESIDENT 15Q "Fault on resident page")
+                      (\MP.STACKFAULT 16Q "Fault on stack")
+                      (\MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)")
+                      (\MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T")
+                      (\MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code")
+                      (\MP.STACKFULL 23Q)
+                      (\MP.MDSFULL 24Q)
+                      (\MP.UNKNOWN.UFN 25Q)
+                      (\MP.ATOMSFULL 26Q)
+                      (\MP.PNAMESFULL 27Q)
+                      (\MP.USECOUNTOVERFLOW 30Q)
+                      (\MP.MDSFULLWARNING 31Q)
+                      (\MP.BADMDSFREELIST 32Q)
+                      (\MP.BADARRAYBLOCK 33Q)
+                      (\MP.BADDELETEBLOCK 34Q)
+                      (\MP.BADARRAYRECLAIM 35Q)
+                      (\MP.BIGREFCNTMISSING 36Q 
+                             "PTR refcnt previously overflowed, but not found in table.")
+                      (\MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table")
+                      (\MP.DELREF0 40Q)
+                      (\MP.PROCERROR 41Q)
+                      (\MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use")
+                      (\MP.32MBINUSE 43Q)
+                      (\MP.TOPUNWOUND 44Q "Unexpected (RETTO T)")
+                      (\MP.STACKRELEASED 45Q)
+                      (\MP.FLUSHLOCKED 46Q)
+                      (\MP.MAPNOTLOCKED 47Q)
+                      (\MP.UNLOCKINGMAP 50Q)
+                      (\MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper")
+                      (\MP.BADRUNTABLE 52Q "Malformed run table for vmem file")))
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \MP.OBSOLETEVMEM 1)
+
+(RPAQ \MP.INVALIDVMEM 2 "Vmem inconsistent at startup")
+
+(RPAQ \MP.IOCBPAGE 3 "No place for IOCB page at startup")
+
+(RPAQ \MP.MOB 4 "Map out of bounds")
+
+(RPAQQ \MP.INVALIDADDR 5)
+
+(RPAQQ \MP.INVALIDVP 6)
+
+(RPAQ \MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain")
+
+(RPAQ \MP.SELECTLOOP 10Q "Loop in \SELECTREALPAGE")
+
+(RPAQ \MP.NEWPAGE 11Q "Attempt to allocate already existing page")
+
+(RPAQ \MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page")
+
+(RPAQ \MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another")
+
+(RPAQ \MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box")
+
+(RPAQ \MP.RESIDENT 15Q "Fault on resident page")
+
+(RPAQ \MP.STACKFAULT 16Q "Fault on stack")
+
+(RPAQ \MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)")
+
+(RPAQ \MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T")
+
+(RPAQ \MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code")
+
+(RPAQQ \MP.STACKFULL 23Q)
+
+(RPAQQ \MP.MDSFULL 24Q)
+
+(RPAQQ \MP.UNKNOWN.UFN 25Q)
+
+(RPAQQ \MP.ATOMSFULL 26Q)
+
+(RPAQQ \MP.PNAMESFULL 27Q)
+
+(RPAQQ \MP.USECOUNTOVERFLOW 30Q)
+
+(RPAQQ \MP.MDSFULLWARNING 31Q)
+
+(RPAQQ \MP.BADMDSFREELIST 32Q)
+
+(RPAQQ \MP.BADARRAYBLOCK 33Q)
+
+(RPAQQ \MP.BADDELETEBLOCK 34Q)
+
+(RPAQQ \MP.BADARRAYRECLAIM 35Q)
+
+(RPAQ \MP.BIGREFCNTMISSING 36Q "PTR refcnt previously overflowed, but not found in table.")
+
+(RPAQ \MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table")
+
+(RPAQQ \MP.DELREF0 40Q)
+
+(RPAQQ \MP.PROCERROR 41Q)
+
+(RPAQ \MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use")
+
+(RPAQQ \MP.32MBINUSE 43Q)
+
+(RPAQ \MP.TOPUNWOUND 44Q "Unexpected (RETTO T)")
+
+(RPAQQ \MP.STACKRELEASED 45Q)
+
+(RPAQQ \MP.FLUSHLOCKED 46Q)
+
+(RPAQQ \MP.MAPNOTLOCKED 47Q)
+
+(RPAQQ \MP.UNLOCKINGMAP 50Q)
+
+(RPAQ \MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper")
+
+(RPAQ \MP.BADRUNTABLE 52Q "Malformed run table for vmem file")
+
+
+(CONSTANTS (\MP.OBSOLETEVMEM 1)
+       (\MP.INVALIDVMEM 2 "Vmem inconsistent at startup")
+       (\MP.IOCBPAGE 3 "No place for IOCB page at startup")
+       (\MP.MOB 4 "Map out of bounds")
+       (\MP.INVALIDADDR 5)
+       (\MP.INVALIDVP 6)
+       (\MP.CHAIN.UNAVAIL 7 "Unavailable page on real page table chain")
+       (\MP.SELECTLOOP 10Q "Loop in \SELECTREALPAGE")
+       (\MP.NEWPAGE 11Q "Attempt to allocate already existing page")
+       (\MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page")
+       (\MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another")
+       (\MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box")
+       (\MP.RESIDENT 15Q "Fault on resident page")
+       (\MP.STACKFAULT 16Q "Fault on stack")
+       (\MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)")
+       (\MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T")
+       (\MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code")
+       (\MP.STACKFULL 23Q)
+       (\MP.MDSFULL 24Q)
+       (\MP.UNKNOWN.UFN 25Q)
+       (\MP.ATOMSFULL 26Q)
+       (\MP.PNAMESFULL 27Q)
+       (\MP.USECOUNTOVERFLOW 30Q)
+       (\MP.MDSFULLWARNING 31Q)
+       (\MP.BADMDSFREELIST 32Q)
+       (\MP.BADARRAYBLOCK 33Q)
+       (\MP.BADDELETEBLOCK 34Q)
+       (\MP.BADARRAYRECLAIM 35Q)
+       (\MP.BIGREFCNTMISSING 36Q "PTR refcnt previously overflowed, but not found in table.")
+       (\MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table")
+       (\MP.DELREF0 40Q)
+       (\MP.PROCERROR 41Q)
+       (\MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use")
+       (\MP.32MBINUSE 43Q)
+       (\MP.TOPUNWOUND 44Q "Unexpected (RETTO T)")
+       (\MP.STACKRELEASED 45Q)
+       (\MP.FLUSHLOCKED 46Q)
+       (\MP.MAPNOTLOCKED 47Q)
+       (\MP.UNLOCKINGMAP 50Q)
+       (\MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper")
+       (\MP.BADRUNTABLE 52Q "Malformed run table for vmem file"))
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ARRAYSPACE \ARRAYSPACE2 \ATOMSPACE \AtomHashTable \SMALLPOSPSPACE \SMALLNEGSPACE 
+       \PNPSPACE \OLDATOMSPACE \DEFSPACE \VALSPACE \PLISTSPACE \PAGEMAP \PageMapTBL \InterfacePage 
+       \IOPAGE \DoveIORegion \IOCBPAGE \FPTOVP \MDSTypeTable \MISCSTATS \UFNTable \DTDSpaceBase 
+       \LISTPDTD \LOCKEDPAGETABLE \STACKSPACE \HTMAIN \HTOVERFLOW \HTBIGCOUNT \HTCOLL \DISPLAYREGION)
+)
+
+(BLOCKRECORD MISCSTATS ((STARTTIME FIXP)
+                        (TOTALTIME FIXP)
+                        (SWAPWAITTIME FIXP)
+                        (PAGEFAULTS FIXP)
+                        (SWAPWRITES FIXP)
+                        (DISKIOTIME FIXP)
+                        (DISKOPS FIXP)
+                        (KEYBOARDWAITTIME FIXP)
+                        (GCTIME FIXP)
+                        (NETIOTIME FIXP)
+                        (NETIOOPS FIXP)
+                        (SWAPTEMP0 FIXP)
+                        (SWAPTEMP1 FIXP)
+                        (RCLKSECOND FIXP)
+                        (SECONDSCLOCK FIXP)
+                        (MILLISECONDSCLOCK FIXP)
+                        (BASECLOCK FIXP)
+                        (RCLKTEMP0 FIXP)
+                        (SECONDSTMP FIXP)
+                        (MILLISECONDSTMP FIXP)
+                        (BASETMP FIXP)
+                        (EXCESSTIMETMP FIXP)
+                        (CLOCKTEMP0 FIXP)
+                        (DISKTEMP0 FIXP)
+                        (DISKTEMP1 FIXP)
+                        (TELERAIDTEMP1 FIXP)
+                        (TELERAIDTEMP2 FIXP)
+                        (TELERAIDTEMP3 FIXP)
+                        (LASTUSERACTION FIXP)
+                        (DLMOUSETIMER FIXP)
+                        (DLMOUSETEMP FIXP))
+       (CREATE (\ALLOCBLOCK 37Q)))
+
+(BLOCKRECORD IFPAGE ((CurrentFXP WORD)                       (* ; 
+                                      "First 7 items are FX values for user and 6 system contexts.")
+                     (ResetFXP WORD)
+                     (SubovFXP WORD)
+                     (KbdFXP WORD)
+                     (HardReturnFXP WORD)
+                     (GCFXP WORD)
+                     (FAULTFXP WORD)
+                     (EndOfStack WORD)                       (* ; 
+                            "Stack high-water mark: address of guard block at current end of stack")
+                     (LVersion WORD)                         (* ; 
+           "Lisp version, followed by min versions of microcode and Bcpl compatible with this Lisp")
+                     (MinRVersion WORD)
+                     (MinBVersion WORD)
+                     (RVersion WORD)                         (* ; 
+                                               "Bcpl fills in the actual microcode, Bcpl versions.")
+                     (BVersion WORD)
+                     (MachineType WORD)
+                     (MiscFXP WORD)                          (* ; "FX for MISC context")
+                     (Key WORD)                              (* ; 
+                                                           "= IFPValidKey if vmem consistent.")
+                     (SerialNumber WORD)                     (* ; 
+                                                           "Pup host number (Dorado/Dolphin)")
+                     (EmulatorSpace WORD)                    (* ; 
+                                                           "Hiloc of bcpl space (always zero now)")
+                     (ScreenWidth WORD)
+                     (NxtPMAddr WORD)                        (* ; 
+                                            "Next page to be allocated in secondary page map table")
+                     (NIL WORD)                              (* ; 
+                                                          "WAS NActivePages, Length of vmem in use")
+                     (NIL WORD)                              (* ; 
+                                      "WAS NDirtyPages, not used, but maintained as = NActivePages")
+                     (filePnPMP0 WORD)                       (* ; "Sysout page number of first page of secondary page map table (\PAGEMAP), which is where the secondary map pages themselves live")
+                     (filePnPMT0 WORD)                       (* ; 
+                                       "Sysout page number of first page of primary page map table")
+                     (TELERAIDFXP WORD)                      (* ; "FX for TeleRaid server context")
+                     (NATIVE-START-MEM-PAGE WORD)            (* ; 
+                                                           "Unix page where native code starts")
+                     (NATIVE-LENGTH-PAGE WORD)               (* ; "Unix page length of native code")
+                     (NATIVE-PAGE-OFFSET WORD)               (* ; 
+                                                           "Lisp Disk Page offset  of native code")
+                     (UserNameAddr WORD)                     (* ; 
+                                 "Addresses in bcpl space (seg 0) of global user name and password")
+                     (UserPswdAddr WORD)
+                     (StackBase WORD)                        (* ; 
+                                                           "Stack address where user stack starts")
+                     (FAULTHI WORD)                          (* ; 
+         "Microcode for page fault stores fault address here, then does context switch to FAULTFXP")
+                     (FAULTLO WORD)
+                     (DEVCONFIG WORD)                        (* ; "IT'S FOR KB,DISP TYPE")
+                                                             (* ; 
+                                   "Formerly REALPAGETABLE, back when it was always in Bcpl space.")
+                     (RPTSIZE WORD)                          (* ; 
+                                                           "Number of entries in Real Page Table")
+                     (RPOFFSET WORD)                         (* ; "RP-RPOFFSET => index in table")
+                     (MAXETHERBYTES WORD)                    (* ; 
+                          "Number of bytes available in a pbi, not counting encapsulation (Dorado)")
+                     (EMBUFVP WORD)                          (* ; 
+                                                           "VP of a one-page emulator buffer")
+                     (NSHost0 WORD)                          (* ; "Machine's 48-bit NS host number.  Lisp manages to compute this on all machines except Dolphin, where Bcpl fills it in.")
+                     (NSHost1 WORD)
+                     (NSHost2 WORD)
+                     (MDSZone WORD)                          (* ; 
+                                               "Obsolete -- was used by Dolphin 10MB network code.")
+                     (MDSZoneLength WORD)
+                     (EMUBUFFERS WORD)                       (* ; 
+                                             "Buffer space in segment 0 for swapping/disk activity")
+                     (EMUBUFLENGTH WORD)                     (* ; "Number of words of said space")
+
+                     (* ;; "The following 2 are available if NEW_STOARGE is specified in C")
+
+                     (ProcessSize WORD)                      (* ; 
+                                                  "Process size for which can be use as LISP space")
+                     (StorageFullState WORD)                 (* ; "Save last storage state")
+                     (ISFMAP WORD)
+
+                     (* ;; "The following 4 are for \MISCAPPLY* -- note that they are not ref counted, so don't pass the only pointer to something this way!")
+
+                     (MISCSTACKFN FULLXPOINTER)
+                     (MISCSTACKARG1 FULLXPOINTER)
+                     (MISCSTACKARG2 FULLXPOINTER)
+                     (MISCSTACKRESULT FULLXPOINTER)
+                     (NRealPages WORD)                       (* ; "Number pages of real memory")
+                     (LastLockedFilePage WORD)               (* ; 
+                         "Last page of vmem that is locked--booting has to load at least that far.")
+                     (LastDominoFilePage WORD)               (* ; 
+                                                "Last sysout page reserved for Dandelion microcode")
+                     (FPTOVPStart WORD)                      (* ; "Sysout page where FPTOVP starts")
+                     (FAKEMOUSEBITS WORD)                    (* ; 
+                                      "Used to implement fake middle button on 2-button Dandelion.")
+                     (DL24BitAddressable WORD)               (* ; 
+                                      "non-zero if DLion capable of addressing 32MB virtual memory")
+                     (REALPAGETABLEPTR FULLXPOINTER)         (* ; 
+                            "Address of real page table, set up by Bcpl (but not chained together)")
+                     (SYSDISK WORD)                          (* ; 
+                       "WAS DLLastVmemPage, DLion booting microcode puts length of vmem file here.")
+                     (FullSpaceUsed WORD)                    (* ; 
+                                          "Non-zero if vmem beyond initial 8MB has been allocated.")
+                     (FAKEKBDAD4 WORD)
+                     (FAKEKBDAD5 WORD)
+
+                     (* ;; "The following 9 items (6 words and 3 pointers) are 3 3-element vectors for the Dorado extended virtual memory code--indexed by 0,1,2 according to which of up to 3 virtual memory backing files you're working with.")
+
+                     (XVmemFmapBase WORD)                    (* ; 
+ "Bcpl stores isf map pointer to each partition here.  First is redundant with ISFMAP field above.")
+                     (NIL WORD)
+                     (NIL WORD)
+                     (XVmemFmapHighBase WORD)                (* ; 
+                          "Bcpl stores the highest vm page contained in this or earlier partition.")
+                     (NIL WORD)
+                     (NIL WORD)
+                     (XVmemDiskBase FULLXPOINTER)            (* ; 
+      "Lisp stores disk objects here (just a convenient non-faulting contiguous block of storage).")
+                     (NIL FULLXPOINTER)
+                     (NIL FULLXPOINTER)
+                     (DLLastVmemPage FIXP)                   (* ; 
+                                           "DLion booting microcode puts length of vmem file here.")
+                     (NActivePages FIXP)                     (* ; "Length of vmem in use")
+                     (NDirtyPages FIXP)                      (* ; 
+                                                       "not used, but maintained as = NActivePages")
+                     )
+       (CREATE (\ALLOCBLOCK 53Q)))
+
+(BLOCKRECORD IOPAGE ((NIL 22Q WORD)
+                     (DLMAINTPANEL WORD)
+                     (DLFLOPPYCMD WORD)
+                     (DLTTYPORTCMD WORD)
+                     (DLPROCESSORCMD WORD)
+                     (NEWMOUSESTATE WORD)
+                     (DLBEEPCMD WORD)
+                     (DLRS232CMISCCOMMAND WORD)
+                     (DLRS232CPUTFLAG WORD)
+                     (DLRS232CGETFLAG WORD)
+                     (NIL 6 WORD)
+                     (DLFLOPPY WORD)
+                     (DLTTYOUT WORD)
+                     (NIL 1 WORD)
+                     (DLTTYIN WORD)
+                     (NIL 1 WORD)
+                     (DLPROCESSOR2 WORD)
+                     (DLPROCESSOR1 WORD)
+                     (DLPROCESSOR0 WORD)
+                     (NEWMOUSEX WORD)
+                     (NEWMOUSEY WORD)
+                     (DLBEEPFREQ WORD)
+                     (DLRS232CPARAMETERCSBLO WORD)
+                     (DLRS232CPARAMETERCSBHI WORD)
+                     (DLRS232CSETRS366STATUS 3 WORD)
+                     (DLRS232CPUTCSBLO WORD)
+                     (DLRS232CPUTCSBHI WORD)
+                     (DLRS232CGETCSBLO WORD)
+                     (DLRS232CGETCSBHI WORD)
+                     (DLRS232CDEVICESTATUS WORD)
+                     (DLRS232CPARAMETEROUTCOME WORD)
+                     (DLTODVALID WORD)
+                     (DLTODLO WORD)
+                     (DLTODHI WORD)
+                     (DLTODLO2 WORD)
+                     (DLMOUSEX WORD)
+                     (DLMOUSEY WORD)
+                     (DLUTILIN WORD)
+                     (DLKBDAD0 WORD)
+                     (DLKBDAD1 WORD)
+                     (DLKBDAD2 WORD)
+                     (DLKBDAD3 WORD)
+                     (DLKBDAD4 WORD)
+                     (DLKBDAD5 WORD)
+                     (DLLSEPIMAGECSB 40Q WORD)
+                     (DLIOPHARDWARECONFIG WORD)
+                     (NIL 13Q WORD)
+                     (DLRS232CPARAMETERCSBLO.11 WORD)
+                     (DLRS232CPARAMETERCSBHI.11 WORD)
+                     (DLRS232CSETRS366STATUS.11 16Q WORD)
+                     (NIL 74Q WORD)
+                     (DLMAGTAPE 4 WORD)
+                     (DLETHERNET 14Q WORD)
+                     (NIL 37Q WORD)
+                     (DLDISPINTERRUPT WORD)
+                     (DLDISPCONTROL WORD)
+                     (DLDISPBORDER WORD)
+                     (DLCURSORX WORD)
+                     (DLCURSORY WORD)
+                     (DLCURSORBITMAP 20Q WORD))
+       [ACCESSFNS IOPAGE ((DLCURSORBITMAPPTR (\ADDBASE DATUM 360Q))
+                          (DLCURSORYPTR (\ADDBASE DATUM 357Q))
+                          (DLCURSORXPTR (\ADDBASE DATUM 356Q))
+                          (DLDISPINTERRUPTPTR (\ADDBASE DATUM 353Q))
+                          (DLETHERNETPTR (\ADDBASE DATUM 300Q))
+                          (DLKBDAD5PTR (\ADDBASE DATUM 103Q))
+                          (DLKBDAD4PTR (\ADDBASE DATUM 102Q))
+                          (DLKBDAD3PTR (\ADDBASE DATUM 101Q))
+                          (DLKBDAD2PTR (\ADDBASE DATUM 100Q))
+                          (DLKBDAD1PTR (\ADDBASE DATUM 77Q))
+                          (DLKBDAD0PTR (\ADDBASE DATUM 76Q))
+                          (DLUTILINPTR (\ADDBASE DATUM 75Q))
+                          (DLMOUSEYPTR (\ADDBASE DATUM 74Q))
+                          (DLMOUSEXPTR (\ADDBASE DATUM 73Q))
+                          (DLTODLOPTR (\ADDBASE DATUM 70Q))
+                          (DLMAINTPANELPTR (\ADDBASE DATUM 22Q]
+       (CREATE (\ALLOCBLOCK 200Q)))
+(DECLARE%: EVAL@COMPILE 
+
+[PUTPROPS EMADDRESS MACRO (ARGS ([LAMBDA (ADDR)
+                                   (COND
+                                      [(EQ \D1BCPLspace \D0BCPLspace)
+                                       (LIST (BIG-VMEM-CODE (LIST 'OPCODES 'GCONST 0 0
+                                                                  (LRSH ADDR 10Q)
+                                                                  (LOGAND ADDR 377Q))
+                                                    (LIST 'OPCODES 'GCONST 0 (LRSH ADDR 10Q)
+                                                          (LOGAND ADDR 377Q]
+                                      (T `(\VAG2 (fetch EmulatorSpace of \InterfacePage)
+                                                 %, ADDR]
+                                 (EVAL (CAR ARGS]
+
+(PUTPROPS EMGETBASE MACRO ((OFFSET)
+                           (\GETBASE (EMADDRESS OFFSET)
+                                  0)))
+
+(PUTPROPS EMPUTBASE MACRO ((OFFSET VAL)
+                           (\PUTBASE (EMADDRESS OFFSET)
+                                  0 VAL)))
+
+(PUTPROPS EMULATORSEGMENT MACRO (NIL (fetch EmulatorSpace of \InterfacePage)))
+
+[PUTPROPS EMPOINTER MACRO (X (COND
+                                ((NEQ \D1BCPLspace \D0BCPLspace)
+                                 (LIST '\VAG2 '(fetch (IFPAGE EmulatorSpace) of 
+                                                                                       \InterfacePage
+                                                      )
+                                       (CAR X)))
+                                ((ZEROP (CAR X))
+                                 NIL)
+                                (T (LIST '\VAG2 \D0BCPLspace (CAR X]
+
+[PUTPROPS EMADDRESSP MACRO (X (LIST 'EQ (LIST '\HILOC (CAR X))
+                                    (COND
+                                       ((EQ \D1BCPLspace \D0BCPLspace)
+                                        \D0BCPLspace)
+                                       (T '(fetch (IFPAGE EmulatorSpace) of \InterfacePage]
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+)
+
+(PUTPROPS LLPARAMS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10Q))
+(PUTPROPS LLPARAMS COPYRIGHT (
+"Syntelligence Systems, Inc.  This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc.  Reverse engineering, reverse compiling and disassembling of object code are prohibited.  Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc.  Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets"
+ 3675Q 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3704Q 3706Q 3707Q 3710Q 3712Q 3716Q))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (7177Q 13221Q (MAKERECORD 7211Q . 13217Q)))))
+STOP
diff --git a/internal/makesysout/sunloadup/LOADBIGFULLFROMLISP-REM.CM b/internal/makesysout/sunloadup/LOADBIGFULLFROMLISP-REM.CM
new file mode 100644
index 00000000..6955cd0f
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADBIGFULLFROMLISP-REM.CM
@@ -0,0 +1,5 @@
+"
+SHH(PROGN (IL:LOAD '\"{dsk}SUNLOADUP/LOADFULL-BIG.LISP\") (IL:MAKESYS '\"{dsk}FULL.SYSOUT\") (IL:LOGOUT T))
+
+"
+
diff --git a/internal/makesysout/sunloadup/LOADFULL-BIG.LISP b/internal/makesysout/sunloadup/LOADFULL-BIG.LISP
new file mode 100644
index 00000000..dc7d5412
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADFULL-BIG.LISP
@@ -0,0 +1,28 @@
+(RESETVARS
+   ((IDLE.PROFILE (QUOTE (TIMEOUT NIL))))
+    (DEL.PROCESS (QUOTE IDLE))
+    (SETQQ DISPLAYFONTDIRECTORIES
+            ("{DSK}/mo/release/fonts/display/presentation/"
+"{DSK}/mo/release/fonts/display/publishing/"
+"{DSK}/mo/release/fonts/display/miscellaneous/" ))
+    (SETQQ INTERPRESSFONTDIRECTORIES
+            ("{DSK}/mo/release/fonts/interpress/presentation/"
+"{DSK}/mo/release/fonts/interpress/publishing/"
+"{DSK}/mo/release/fonts/interpress/miscellaneous/" ))
+    (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
+    (SETQQ LOADUPDIRECTORIES
+            ({dsk}~/4-byte-lib/ {dsk}~/4-byte-intlib/
+			 {dsk}/king/export/lispcore/lafite/parc-94/
+			 {dsk}/king/export/lispcore/library/
+			 {dsk}/king/export/lispcore/internal/library/
+))
+  (* used to include after EDITBITMAL: MAILCLIENT NSMAIL LAFITE NEWNSMAIL)
+  (* used to include MAILCLIENT before NSMAIL )
+  (LOADUP (QUOTE (MSANALYZE MSPARSE MASTERSCOPE GIVE-AND-TAKE CHANGECONTROL CHAT PUPCHAT NSCHAT TEDIT HRULE
+				  TEDITCHAT READNUMBER EDITBITMAP NSMAIL LAFITE
+				  NEWNSMAIL FILEBROWSER GRAPHER SPY AREDIT WHERE-IS COPYFILES
+				  UNIXCOMM UNIXCHAT
+				  POSTSCRIPTSTREAM UNIXPRINT)))
+  (\DAYTIME0 \LASTUSERACTION)
+  (ENDLOADUP))
+STOP
diff --git a/internal/makesysout/sunloadup/LOADFULL-REM.CM b/internal/makesysout/sunloadup/LOADFULL-REM.CM
new file mode 100644
index 00000000..4516887c
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADFULL-REM.CM
@@ -0,0 +1,7 @@
+"
+(PROGN (LOAD (QUOTE {dsk}~/lispcore/SUNLOADUP/LOADUP.LISP))(SETQ IL:MAKESYSNAME :MEDLEY)(HARDRESET))
+SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'LISP.SYSOUT))
+SHH(PROGN (IL:LOAD '{dsk}~/lispcore/SUNLOADUP/LOADFULL.LISP) (IL:MAKESYS 'FULL.SYSOUT) (IL:LOGOUT T))
+
+"
+
diff --git a/internal/makesysout/sunloadup/LOADFULL.LISP b/internal/makesysout/sunloadup/LOADFULL.LISP
new file mode 100644
index 00000000..d7290d01
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADFULL.LISP
@@ -0,0 +1,29 @@
+(RESETVARS
+   ((IDLE.PROFILE (QUOTE (TIMEOUT NIL))))
+    (DEL.PROCESS (QUOTE IDLE))
+    (SETQQ DISPLAYFONTDIRECTORIES
+            ("{DSK}~/lispcore/fonts/display/presentation/"
+"{DSK}~/lispcore/fonts/display/publishing/"
+"{DSK}~/lispcore/fonts/display/miscellaneous/" ))
+    (SETQQ INTERPRESSFONTDIRECTORIES
+            ("{DSK}~/lispcore/fonts/interpress/presentation/"
+"{DSK}~/lispcore/fonts/interpress/publishing/"
+"{DSK}~/lispcore/fonts/interpress/miscellaneous/" ))
+    (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
+    (SETQQ LOADUPDIRECTORIES
+            ({dsk}~/lispcore/lafite/medley-2.01/
+			 {dsk}~/lispcore/library/
+			 {dsk}~/lispcore/internal/library/
+			 
+))
+	(SETQ CH.DEFAULT.DOMAIN "MV") (SETQ CH.DEFAULT.ORGANIZATION "Envos")
+  (* used to include after EDITBITMAL: MAILCLIENT NSMAIL LAFITE NEWNSMAIL)
+  (LOADUP (QUOTE (MSPARSE MSANALYZE MASTERSCOPE 
+						  GIVE-AND-TAKE CHANGECONTROL CHAT PUPCHAT NSCHAT TEDIT HRULE
+				  TEDITCHAT READNUMBER EDITBITMAP MAILCLIENT NSMAIL LAFITE
+				  NEWNSMAIL FILEBROWSER GRAPHER SPY AREDIT WHERE-IS COPYFILES
+				  UNIXCOMM UNIXCHAT
+				  POSTSCRIPTSTREAM UNIXPRINT MULTI-COMPILE)))
+  (\DAYTIME0 \LASTUSERACTION)
+  (ENDLOADUP))
+STOP
diff --git a/internal/makesysout/sunloadup/LOADFULLFROMLISP-REM.CM b/internal/makesysout/sunloadup/LOADFULLFROMLISP-REM.CM
new file mode 100644
index 00000000..57b12cf8
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADFULLFROMLISP-REM.CM
@@ -0,0 +1,5 @@
+"
+SHH(PROGN (IL:LOAD '\"{dsk}/disk/disk2/jdstools/lc3/lispcore3.0/SUNLOADUP/LOADFULL.LISP\") (IL:MAKESYS '\"{dsk}FULL.SYSOUT\") (IL:LOGOUT T))
+
+"
+
diff --git a/internal/makesysout/sunloadup/LOADUP-BIG.LISP b/internal/makesysout/sunloadup/LOADUP-BIG.LISP
new file mode 100644
index 00000000..602c01df
Binary files /dev/null and b/internal/makesysout/sunloadup/LOADUP-BIG.LISP differ
diff --git a/internal/makesysout/sunloadup/LOADUP-NOCOMPILER-REM.CM b/internal/makesysout/sunloadup/LOADUP-NOCOMPILER-REM.CM
new file mode 100644
index 00000000..7aa27269
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP-NOCOMPILER-REM.CM
@@ -0,0 +1,6 @@
+"
+(SETQQ MAKESYSNAME NOCOMPILER)
+(PROGN (LOAD (QUOTE {dsk}/users/osamu/SUNLOADUP/LOADUP-NOCOMPILER.LISP))(HARDRESET))
+SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'NOCOMPILER.SYSOUT))
+"
+
diff --git a/internal/makesysout/sunloadup/LOADUP-NOCOMPILER.LISP b/internal/makesysout/sunloadup/LOADUP-NOCOMPILER.LISP
new file mode 100644
index 00000000..1504bac7
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP-NOCOMPILER.LISP
@@ -0,0 +1,83 @@
+(* " '90/02/15 Osamu: Remove D-Machine specific file")
+(* " Remove DPUPFT DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY")
+(SETQQ COMPILE.EXT LCOM)
+
+(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES))
+
+(SETQ BOOTLOADEDFILES)
+
+(* "following files are really loaded earlier, this call to LOADUP just cleans up")
+(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP)))
+
+(* "establish all package exports early")
+(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE)))
+
+(* "turn on FTP so that loadup will be faster")
+(* "Osamu '90/02/15 remove DPUPFTP")
+(LOADUP (QUOTE (BSP)))
+
+(* "load FASL loader here, so we can load DFASLs earlier in loadup")
+(LOADUP (QUOTE (ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD)))
+
+(* "These are needed by any FASL files")
+(LOADUP (QUOTE (DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON CMLSEQMAPPERS CMLPATHNAME CMLFILESYS)))
+
+(* * * "FASL files may be loaded after this point" * * *)
+
+(LOADUP (QUOTE (CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS)))
+
+(* "early runtime support for Common Lisp and (temporarily) debugger")
+(LOADUP (QUOTE (STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS)))
+
+(LOADUP (QUOTE (COMMON XCLC-RUNTIME CMLTYPES CL-ERROR)))
+
+(LOADUP (QUOTE (AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE)))
+
+(* "The Byte Compiler (DLAP, BYTECOMPILER, COMPILER) used to be here.  Moved after
+    XCL Compiler so that one byte compiler init will work.  JDS 10/11/89")
+
+(LOADUP (QUOTE (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD)))
+
+(LOADUP (QUOTE (GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE)))
+
+(DWIM (QUOTE C))
+
+(* "Kernel Common Lisp files")
+(LOADUP (QUOTE (CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES)))
+
+(LOADUP (QUOTE (PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT)))
+
+(LOADUP (QUOTE (ADDARITH)))
+
+(LOADUP (QUOTE (CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON LOGOW PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)))
+
+(LOADUP (QUOTE (BREAK-AND-TRACE)))
+
+(* "remove FASDUMP XCL-COMPILER '90/02/16 Osamu")
+(LOADUP (QUOTE (ADVISE)))
+
+(* "the bytecompiler and Interlisp compiler interface functions")
+(* "remove DLAP BYTECOMPILER COMPILE '90/02/16 Osamu")
+(* "(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE)))")
+
+(* "remove DISKDLION  DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY TRSERVER '90/02/15 Osamu")
+(LOADUP (QUOTE (LOCALFILE 10MBDRIVER MAIKOETHER LLNS SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS  IDLER ICONW FREEMENU SEDIT)))
+
+(LOADUP (QUOTE (DSK UFS UFSCALLC MAIKOBITBLT)))
+
+(LOADUP (QUOTE (TIME)))
+
+(LOADUP (QUOTE (XCL-EXTRAS)))
+
+(* "CMLPACKAGE pushes onto INSPECTMACROS")
+(LOADUP (QUOTE (CMLPACKAGE)))
+
+(* "Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs")
+(LOADUP (QUOTE (CMLSMARTARGS)))
+
+(LOADUP (QUOTE (IMPLICIT-KEY-HASH CLOSURE-CACHE)))
+
+(* "Already enabled, but this time fixes tables that weren't defined in the init")
+(PACKAGE-ENABLE)
+
+STOP
diff --git a/internal/makesysout/sunloadup/LOADUP-NODMACHINE-REM.CM b/internal/makesysout/sunloadup/LOADUP-NODMACHINE-REM.CM
new file mode 100644
index 00000000..d4e2e033
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP-NODMACHINE-REM.CM
@@ -0,0 +1,6 @@
+"
+(SETQQ MAKESYSNAME NODMACHINE)
+(PROGN (LOAD (QUOTE {dsk}/users/osamu/SUNLOADUP/LOADUP-NODMACHINE.LISP))(HARDRESET))
+SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'NODMACHINE.SYSOUT))
+"
+
diff --git a/internal/makesysout/sunloadup/LOADUP-NODMACHINE.LISP b/internal/makesysout/sunloadup/LOADUP-NODMACHINE.LISP
new file mode 100644
index 00000000..28949ec3
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP-NODMACHINE.LISP
@@ -0,0 +1,81 @@
+(* " '90/02/15 Osamu: Remove D-Machine specific file")
+(* " Remove DPUPFT DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY")
+(SETQQ COMPILE.EXT LCOM)
+
+(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES))
+
+(SETQ BOOTLOADEDFILES)
+
+(* "following files are really loaded earlier, this call to LOADUP just cleans up")
+(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP)))
+
+(* "establish all package exports early")
+(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE)))
+
+(* "turn on FTP so that loadup will be faster")
+(* "Osamu '90/02/15 remove DPUPFTP")
+(LOADUP (QUOTE (BSP)))
+
+(* "load FASL loader here, so we can load DFASLs earlier in loadup")
+(LOADUP (QUOTE (ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD)))
+
+(* "These are needed by any FASL files")
+(LOADUP (QUOTE (DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON CMLSEQMAPPERS CMLPATHNAME CMLFILESYS)))
+
+(* * * "FASL files may be loaded after this point" * * *)
+
+(LOADUP (QUOTE (CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS)))
+
+(* "early runtime support for Common Lisp and (temporarily) debugger")
+(LOADUP (QUOTE (STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS)))
+
+(LOADUP (QUOTE (COMMON XCLC-RUNTIME CMLTYPES CL-ERROR)))
+
+(LOADUP (QUOTE (AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE)))
+
+(* "The Byte Compiler (DLAP, BYTECOMPILER, COMPILER) used to be here.  Moved after
+    XCL Compiler so that one byte compiler init will work.  JDS 10/11/89")
+
+(LOADUP (QUOTE (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD)))
+
+(LOADUP (QUOTE (GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE)))
+
+(DWIM (QUOTE C))
+
+(* "Kernel Common Lisp files")
+(LOADUP (QUOTE (CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES)))
+
+(LOADUP (QUOTE (PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT)))
+
+(LOADUP (QUOTE (ADDARITH)))
+
+(LOADUP (QUOTE (CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON LOGOW PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)))
+
+(LOADUP (QUOTE (BREAK-AND-TRACE)))
+
+(LOADUP (QUOTE (FASDUMP XCL-COMPILER ADVISE)))
+
+(* "the bytecompiler and Interlisp compiler interface functions")
+(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE)))
+
+(* "remove DISKDLION  DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY TRSERVER '90/02/15 Osamu")
+(LOADUP (QUOTE (LOCALFILE 10MBDRIVER MAIKOETHER LLNS SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS  IDLER ICONW FREEMENU SEDIT)))
+
+(LOADUP (QUOTE (DSK UFS UFSCALLC MAIKOBITBLT)))
+
+(LOADUP (QUOTE (TIME)))
+
+(LOADUP (QUOTE (XCL-EXTRAS)))
+
+(* "CMLPACKAGE pushes onto INSPECTMACROS")
+(LOADUP (QUOTE (CMLPACKAGE)))
+
+(* "Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs")
+(LOADUP (QUOTE (CMLSMARTARGS)))
+
+(LOADUP (QUOTE (IMPLICIT-KEY-HASH CLOSURE-CACHE)))
+
+(* "Already enabled, but this time fixes tables that weren't defined in the init")
+(PACKAGE-ENABLE)
+
+STOP
diff --git a/internal/makesysout/sunloadup/LOADUP-NOETHER-REM.CM b/internal/makesysout/sunloadup/LOADUP-NOETHER-REM.CM
new file mode 100644
index 00000000..cc898fd5
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP-NOETHER-REM.CM
@@ -0,0 +1,6 @@
+"
+(SETQQ MAKESYSNAME NOETHER)
+(PROGN (LOAD (QUOTE {dsk}/users/osamu/SUNLOADUP/LOADUP-NOETHER.LISP))(HARDRESET))
+SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'NOETHER.SYSOUT))
+"
+
diff --git a/internal/makesysout/sunloadup/LOADUP-NOETHER.LISP b/internal/makesysout/sunloadup/LOADUP-NOETHER.LISP
new file mode 100644
index 00000000..058c42fc
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP-NOETHER.LISP
@@ -0,0 +1,82 @@
+(* "Makeing LISP.SYSOUT that doesn't support XNS and PUP. '90/02/15 Osamu")
+
+(SETQQ COMPILE.EXT LCOM)
+
+(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES))
+
+(SETQ BOOTLOADEDFILES)
+
+(* "following files are really loaded earlier, this call to LOADUP just cleans up")
+(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP)))
+
+(* "establish all package exports early")
+(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE)))
+
+(* "turn on FTP so that loadup will be faster")
+(* "'90/02/15 Osamu: Remove DPUPFTP")
+(LOADUP (QUOTE (BSP)))
+
+(* "load FASL loader here, so we can load DFASLs earlier in loadup")
+(LOADUP (QUOTE (ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD)))
+
+(* "These are needed by any FASL files")
+(LOADUP (QUOTE (DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON CMLSEQMAPPERS CMLPATHNAME CMLFILESYS)))
+
+(* * * "FASL files may be loaded after this point" * * *)
+
+(LOADUP (QUOTE (CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS)))
+
+(* "early runtime support for Common Lisp and (temporarily) debugger")
+(LOADUP (QUOTE (STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS)))
+
+(LOADUP (QUOTE (COMMON XCLC-RUNTIME CMLTYPES CL-ERROR)))
+
+(LOADUP (QUOTE (AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE)))
+
+(* "The Byte Compiler (DLAP, BYTECOMPILER, COMPILER) used to be here.  Moved after
+    XCL Compiler so that one byte compiler init will work.  JDS 10/11/89")
+
+(LOADUP (QUOTE (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD)))
+
+(LOADUP (QUOTE (GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE)))
+
+(DWIM (QUOTE C))
+
+(* "Kernel Common Lisp files")
+(LOADUP (QUOTE (CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES)))
+
+(LOADUP (QUOTE (PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT)))
+
+(LOADUP (QUOTE (ADDARITH)))
+
+(LOADUP (QUOTE (CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON LOGOW PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)))
+
+(LOADUP (QUOTE (BREAK-AND-TRACE)))
+
+(LOADUP (QUOTE (FASDUMP XCL-COMPILER ADVISE)))
+
+(* "the bytecompiler and Interlisp compiler interface functions")
+(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE)))
+
+(* "'90/02/15 Osamu: Remove LLNS TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS")
+
+(LOADUP (QUOTE (DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY 10MBDRIVER MAIKOETHER HARDCOPY  FLOPPY IDLER ICONW FREEMENU SEDIT)))
+
+(LOADUP (QUOTE (DSK UFS UFSCALLC MAIKOBITBLT)))
+
+(LOADUP (QUOTE (TIME)))
+
+(LOADUP (QUOTE (XCL-EXTRAS)))
+
+(* "CMLPACKAGE pushes onto INSPECTMACROS")
+(LOADUP (QUOTE (CMLPACKAGE)))
+
+(* "Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs")
+(LOADUP (QUOTE (CMLSMARTARGS)))
+
+(LOADUP (QUOTE (IMPLICIT-KEY-HASH CLOSURE-CACHE)))
+
+(* "Already enabled, but this time fixes tables that weren't defined in the init")
+(PACKAGE-ENABLE)
+
+STOP
diff --git a/internal/makesysout/sunloadup/LOADUP-NOXCLCOMPILER-REM.CM b/internal/makesysout/sunloadup/LOADUP-NOXCLCOMPILER-REM.CM
new file mode 100644
index 00000000..e774ccda
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP-NOXCLCOMPILER-REM.CM
@@ -0,0 +1,6 @@
+"
+(SETQQ MAKESYSNAME NOXCLCOMPILER)
+(PROGN (LOAD (QUOTE {dsk}/users/osamu/SUNLOADUP/LOADUP-NOXCLCOMPILER.LISP))(HARDRESET))
+SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'NOXCLCOMPILER.SYSOUT))
+"
+
diff --git a/internal/makesysout/sunloadup/LOADUP-NOXCLCOMPILER.LISP b/internal/makesysout/sunloadup/LOADUP-NOXCLCOMPILER.LISP
new file mode 100644
index 00000000..537ddd31
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP-NOXCLCOMPILER.LISP
@@ -0,0 +1,84 @@
+(* " '90/02/15 Osamu: Remove D-Machine specific file")
+(* " Remove DPUPFT DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY")
+(* " '90/02/19 Osamu: Remove XCL Compiler.")
+(* " Remove FASDUMP XCL-COMPILER. '90/02/19 Osamu")
+(SETQQ COMPILE.EXT LCOM)
+
+(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES))
+
+(SETQ BOOTLOADEDFILES)
+
+(* "following files are really loaded earlier, this call to LOADUP just cleans up")
+(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP)))
+
+(* "establish all package exports early")
+(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE)))
+
+(* "turn on FTP so that loadup will be faster")
+(* "Osamu '90/02/15 remove DPUPFTP")
+(LOADUP (QUOTE (BSP)))
+
+(* "load FASL loader here, so we can load DFASLs earlier in loadup")
+(LOADUP (QUOTE (ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD)))
+
+(* "These are needed by any FASL files")
+(LOADUP (QUOTE (DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON CMLSEQMAPPERS CMLPATHNAME CMLFILESYS)))
+
+(* * * "FASL files may be loaded after this point" * * *)
+
+(LOADUP (QUOTE (CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS)))
+
+(* "early runtime support for Common Lisp and (temporarily) debugger")
+(LOADUP (QUOTE (STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS)))
+
+(LOADUP (QUOTE (COMMON XCLC-RUNTIME CMLTYPES CL-ERROR)))
+
+(LOADUP (QUOTE (AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE)))
+
+(* "The Byte Compiler (DLAP, BYTECOMPILER, COMPILER) used to be here.  Moved after
+    XCL Compiler so that one byte compiler init will work.  JDS 10/11/89")
+
+(LOADUP (QUOTE (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD)))
+
+(LOADUP (QUOTE (GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE)))
+
+(DWIM (QUOTE C))
+
+(* "Kernel Common Lisp files")
+(LOADUP (QUOTE (CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES)))
+
+(LOADUP (QUOTE (PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT)))
+
+(LOADUP (QUOTE (ADDARITH)))
+
+(LOADUP (QUOTE (CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON LOGOW PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)))
+
+(LOADUP (QUOTE (BREAK-AND-TRACE)))
+
+(* "Remove FASDUMP XCL-COMPILER. '90/02/19 Osamu")
+(LOADUP (QUOTE (ADVISE)))
+
+(* "the bytecompiler and Interlisp compiler interface functions")
+(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE)))
+
+(* "remove DISKDLION  DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY TRSERVER '90/02/15 Osamu")
+(LOADUP (QUOTE (LOCALFILE 10MBDRIVER MAIKOETHER LLNS SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS  IDLER ICONW FREEMENU SEDIT)))
+
+(LOADUP (QUOTE (DSK UFS UFSCALLC MAIKOBITBLT)))
+
+(LOADUP (QUOTE (TIME)))
+
+(LOADUP (QUOTE (XCL-EXTRAS)))
+
+(* "CMLPACKAGE pushes onto INSPECTMACROS")
+(LOADUP (QUOTE (CMLPACKAGE)))
+
+(* "Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs")
+(LOADUP (QUOTE (CMLSMARTARGS)))
+
+(LOADUP (QUOTE (IMPLICIT-KEY-HASH CLOSURE-CACHE)))
+
+(* "Already enabled, but this time fixes tables that weren't defined in the init")
+(PACKAGE-ENABLE)
+
+STOP
diff --git a/internal/makesysout/sunloadup/LOADUP-REM.CM b/internal/makesysout/sunloadup/LOADUP-REM.CM
new file mode 100644
index 00000000..5da6248a
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP-REM.CM
@@ -0,0 +1,5 @@
+"
+(PROGN (LOAD (QUOTE {dsk}SUNLOADUP/LOADUP.LISP))(SETQ IL:MAKESYSNAME :MEDLEY)(HARDRESET))
+SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'LISP.SYSOUT))
+"
+
diff --git a/internal/makesysout/sunloadup/LOADUP-REM.CM% b/internal/makesysout/sunloadup/LOADUP-REM.CM%
new file mode 100644
index 00000000..4230049a
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP-REM.CM%
@@ -0,0 +1,6 @@
+"
+(SETQQ MAKESYSNAME LISPCORE)
+(PROGN (LOAD (QUOTE {dsk}SUNLOADUP/LOADUP.LISP))(HARDRESET))
+SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'LISP.SYSOUT))
+"
+
diff --git a/internal/makesysout/sunloadup/LOADUP.LISP b/internal/makesysout/sunloadup/LOADUP.LISP
new file mode 100644
index 00000000..086575b2
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP.LISP
@@ -0,0 +1,96 @@
+(* " (C) COPYRIGHT 1991 Venue.  All Rights Reserved.  Manufactured in the United States of America.")
+
+(SETQQ COMPILE.EXT LCOM)
+
+(* "For 4-byte sysouts, must put 4-BYTE into the HOST-ARCHITECTURE list")
+
+(SETQ COMPILER*HOST-ARCHITECTURE* (QUOTE (4-BYTE 3-BYTE)))
+(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES))
+
+(SETQ BOOTLOADEDFILES)
+
+(* "following files are really loaded earlier, this call to LOADUP just cleans up")
+(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP)))
+
+(* "establish all package exports early")
+(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE)))
+
+(* "turn on FTP so that loadup will be faster")
+(LOADUP (QUOTE (BSP DPUPFTP)))
+
+(* "load FASL loader here, so we can load DFASLs earlier in loadup")
+(LOADUP (QUOTE (ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD)))
+
+(* "These are needed by any FASL files")
+(LOADUP (QUOTE (DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON CMLSEQMAPPERS CMLPATHNAME CMLFILESYS)))
+
+(* * * "FASL files may be loaded after this point" * * *)
+
+(LOADUP (QUOTE (CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS)))
+
+(* "early runtime support for Common Lisp and (temporarily) debugger")
+(LOADUP (QUOTE (STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS)))
+
+(LOADUP (QUOTE (COMMON XCLC-RUNTIME CMLTYPES CL-ERROR)))
+
+(LOADUP (QUOTE (AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE)))
+
+(* "The Byte Compiler (DLAP, BYTECOMPILER, COMPILER) used to be here.  Moved after
+    XCL Compiler so that one byte compiler init will work.  JDS 10/11/89")
+
+(LOADUP (QUOTE (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD)))
+
+(LOADUP (QUOTE (GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE)))
+
+(DWIM (QUOTE C))
+
+(* "Kernel Common Lisp files")
+(LOADUP (QUOTE (CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES)))
+
+(LOADUP (QUOTE (PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT)))
+
+(LOADUP (QUOTE (ADDARITH)))
+
+(LOADUP (QUOTE (CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON LOGOW PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)))
+
+(LOADUP (QUOTE (BREAK-AND-TRACE)))
+
+(LOADUP (QUOTE (FASDUMP XCL-COMPILER ADVISE)))
+
+(* "the bytecompiler and Interlisp compiler interface functions")
+(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE)))
+
+(* "3/5/91 JDS: Removed from the following DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY [before LOCALFILE], FLOPPY [after INTERPRESS].")
+
+(LOADUP (QUOTE ( LOCALFILE DSKDISPLAY 10MBDRIVER MAIKOETHER LLNS TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS IDLER ICONW FREEMENU SEDIT)))
+
+(LOADUP (QUOTE (DSK UFS UFSCALLC MAIKOBITBLT)))
+
+(LOADUP (QUOTE (TIME)))
+
+(LOADUP (QUOTE (XCL-EXTRAS)))
+
+(* "CMLPACKAGE pushes onto INSPECTMACROS")
+(LOADUP (QUOTE (CMLPACKAGE)))
+
+(* "Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs")
+(LOADUP (QUOTE (CMLSMARTARGS)))
+
+(LOADUP (QUOTE (IMPLICIT-KEY-HASH CLOSURE-CACHE)))
+
+(* "Already enabled, but this time fixes tables that weren't defined in the init")
+(PACKAGE-ENABLE)
+
+(* "The ethernet eventfn was removed in the early INIT building, to avoid trouble with turning on the ENet in ldeinit.  Put it back, now.  To do that, we have to set up the Maiko ethernet-handling fns from MAIKO.MOVDS....")
+(\MAIKO.DO.MOVDS)
+(SETQ \MACHINETYPE 3)
+(INITPUPLEVEL1)
+(MOVD (QUOTE \ETHEREVENTFN-) (QUOTE \ETHEREVENTFN))
+(MOVD NIL (QUOTE \ETHEREVENTFN-))
+(\NSINIT)
+(\ETHEREVENTFN)
+(\NSINIT)
+(\ETHEREVENTFN)
+(RESTART.ETHER)
+
+STOP
diff --git a/internal/makesysout/sunloadup/LOADUP.LISP% b/internal/makesysout/sunloadup/LOADUP.LISP%
new file mode 100644
index 00000000..8d0eb45a
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP.LISP%
@@ -0,0 +1,85 @@
+(SETQQ COMPILE.EXT LCOM)
+(SETQ COMPILER*HOST-ARCHITECTURE* (QUOTE (3-BYTE)))
+(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES))
+
+(SETQ BOOTLOADEDFILES)
+
+(* "following files are really loaded earlier, this call to LOADUP just cleans up")
+(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP)))
+
+(* "establish all package exports early")
+(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE)))
+
+(* "turn on FTP so that loadup will be faster")
+(LOADUP (QUOTE (BSP DPUPFTP)))
+
+(* "load FASL loader here, so we can load DFASLs earlier in loadup")
+(LOADUP (QUOTE (ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD)))
+
+(* "These are needed by any FASL files")
+(LOADUP (QUOTE (DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON CMLSEQMAPPERS CMLPATHNAME CMLFILESYS)))
+
+(* * * "FASL files may be loaded after this point" * * *)
+
+(LOADUP (QUOTE (CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS)))
+
+(* "early runtime support for Common Lisp and (temporarily) debugger")
+(LOADUP (QUOTE (STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS)))
+
+(LOADUP (QUOTE (COMMON XCLC-RUNTIME CMLTYPES CL-ERROR)))
+
+(LOADUP (QUOTE (AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE)))
+
+(* "The Byte Compiler (DLAP, BYTECOMPILER, COMPILER) used to be here.  Moved after
+    XCL Compiler so that one byte compiler init will work.  JDS 10/11/89")
+
+(LOADUP (QUOTE (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD)))
+
+(LOADUP (QUOTE (GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE)))
+
+(DWIM (QUOTE C))
+
+(* "Kernel Common Lisp files")
+(LOADUP (QUOTE (CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES)))
+
+(LOADUP (QUOTE (PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT)))
+
+(LOADUP (QUOTE (ADDARITH)))
+
+(LOADUP (QUOTE (CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON LOGOW PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)))
+
+(LOADUP (QUOTE (BREAK-AND-TRACE)))
+
+(LOADUP (QUOTE (FASDUMP XCL-COMPILER ADVISE)))
+
+(* "the bytecompiler and Interlisp compiler interface functions")
+(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE)))
+
+
+(LOADUP (QUOTE (DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY 10MBDRIVER MAIKOETHER LLNS TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS FLOPPY IDLER ICONW FREEMENU SEDIT)))
+
+(LOADUP (QUOTE (DSK UFS UFSCALLC MAIKOBITBLT)))
+
+(LOADUP (QUOTE (TIME)))
+
+(LOADUP (QUOTE (XCL-EXTRAS)))
+
+(* "CMLPACKAGE pushes onto INSPECTMACROS")
+(LOADUP (QUOTE (CMLPACKAGE)))
+
+(* "Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs")
+(LOADUP (QUOTE (CMLSMARTARGS)))
+
+(LOADUP (QUOTE (IMPLICIT-KEY-HASH CLOSURE-CACHE)))
+
+(* "Already enabled, but this time fixes tables that weren't defined in the init")
+(PACKAGE-ENABLE)
+
+(* "The ethernet eventfn was removed in the early INIT building, to avoid trouble with turning on the ENet in ldeinit.  Put it back, now:")
+(SETQ \MACHINETYPE 3)
+(MOVD (QUOTE \ETHEREVENTFN-) (QUOTE \ETHEREVENTFN))
+(MOVD NIL (QUOTE \ETHEREVENTFN-))
+(\NSINIT)
+(RESTART.ETHER)
+
+STOP
diff --git a/internal/makesysout/sunloadup/LOADUP.LOG b/internal/makesysout/sunloadup/LOADUP.LOG
new file mode 100644
index 00000000..b6a48079
--- /dev/null
+++ b/internal/makesysout/sunloadup/LOADUP.LOG
@@ -0,0 +1 @@
+
{DSK}<tilde>sybalsky>lispcore>sunloadup>FILESETS.;1
File created  9-Apr-90 16:57:44
FILESETSCOMS

{DSK}<tilde>sybalsky>lispcore>library>VMEM.LCOM;1
compiled on 21-Jan-93 18:50:40
File created 20-Jan-93 15:04:46
VMEMCOMS

{DSK}<tilde>sybalsky>lispcore>sources>MEM.LCOM;3
compiled on 25-Jan-98 17:45:42
File created  5-Nov-92 15:57:00
MEMCOMS
=|{DSK}<tilde>sybalsky>lispcore>sources>READSYS.LCOM;2|

{DSK}<tilde>sybalsky>lispcore>sources>READSYS.LCOM;2
compiled on 30-Jan-98 11:49:54
File created  9-Nov-92 03:25:43
READSYSCOMS

{DSK}<tilde>sybalsky>lispcore>library>RDSYS.LCOM;16
compiled on 20-Dec-98 14:54:58
File created 20-Dec-98 14:54:54
RDSYSCOMS

{DSK}<tilde>sybalsky>lispcore>sources>DTDECLARE.LCOM;6
compiled on 25-Jan-98 12:59:44
File created  8-Mar-95 10:22:57
(/DECLAREDATATYPE redefined)
(DECLAREDATATYPE redefined)
(TRANSLATE.DATATYPE redefined)
(\\REUSETO redefined)
(\\TYPEGLOBALVARIABLE redefined)
(TYPE-VARIABLE-FROM-TYPE-NAME redefined)
(|BitFieldMask| redefined)
(|BitFieldShift| redefined)
(|BitFieldShiftedMask| redefined)
(|MakeBitField| redefined)
(|BitFieldWidth| redefined)
(|BitFieldFirst| redefined)
(|optimize-FETCHFIELD| redefined)
(|optimize-FFETCHFIELD| redefined)
(|optimize-REPLACEFIELD| redefined)
(|optimize-FREPLACEFIELD| redefined)
(|optimize-REPLACEFIELDVAL| redefined)
(|optimize-FREPLACEFIELDVAL| redefined)
(|optimize-NCREATE| redefined)
(|optimize-\\DTEST| redefined)
(COMPILEDFETCHFIELD redefined)
(COMPILEDREPLACEFIELD redefined)
(COMPILEDNCREATE redefined)
(TRANSLATE.LOCF redefined)

{DSK}<tilde>sybalsky>lispcore>sources>RENAMEFNS.LCOM;5
compiled on 29-Jan-98 15:47:13
File created 29-Jan-98 15:47:09

{DSK}<tilde>sybalsky>lispcore>sources>MAKEINIT.LCOM;9
compiled on 31-Jan-98 09:41:08
File created 30-Jan-98 12:46:00
MAKEINITCOMS

{DSK}<tilde>sybalsky>lispcore>sources>DLFIXINIT.LCOM;1
compiled on 31-Jan-98 09:40:56
File created 29-Jan-98 17:51:06
DLFIXINITCOMS

{DSK}<tilde>sybalsky>lispcore>sources>CMLARRAY-SUPPORT.LCOM;2
compiled on  2-May-99 14:58:00
File created  2-May-99 14:57:41

{DSK}<tilde>sybalsky>lispcore>sunloadup>FASTINIT.DFASL;3
XCL Compiler output for source file {DSK}<disk1>lispcore3.0>SUNLOADUP>FASTINIT.;1
Source file created Wednesday, 18 July 1990, 13:20:03.
FASL file created Saturday, 24 January 1998, 15:46:32.


{DSK}<tilde>sybalsky>lispcore>sunloadup>LLPARAMS.;1
File created 31-Jan-98 09:16:51
LLPARAMSCOMS

{DSK}<tilde>sybalsky>lispcore>sources>LLCODE.;1
File created 19-Jan-93 10:45:33
LLCODECOMS
(INEWCOMS reset)
(DONTCOMPILEFNS reset)
(INEWCOMS reset)
(MKI.SUBFNS reset)
(NLAMA reset)

{DSK}<tilde>sybalsky>lispcore>sources>LLARRAYELT.;8
File created 15-Sep-94 11:08:59
LLARRAYELTCOMS

{DSK}<tilde>sybalsky>lispcore>sources>RENAMEMACROS.;3
File created 27-Apr-94 15:43:27
RENAMEMACROSCOMS
(RD.SUBFNS reset)
(MKI.SUBFNS reset)
(EXPANDMACROFNS reset)
(EXPANDMACROFNS reset)
(INEWCOMS reset)
(MKI.SUBFNS reset)
(EXPANDMACROFNS reset)
(RDCOMS reset)
(RD.SUBFNS reset)
(DONTCOMPILEFNS reset)
(DONTCOMPILEFNS reset)
(DONTCOMPILEFNS reset)
(LAMA reset)

{DSK}<tilde>sybalsky>lispcore>sources>LLCHAR.;3
File created 12-Jan-94 10:12:34
LLCHARCOMS
(INEWCOMS reset)
(INEWCOMS reset)
(EXPANDMACROFNS reset)
(DONTCOMPILEFNS reset)

{DSK}<tilde>sybalsky>lispcore>sources>LLNEW.;16
File created  2-Feb-95 16:21:44
LLNEWCOMS
(INEWCOMS reset)
(RDCOMS reset)
(INITPTRS reset)
(MKI.SUBFNS reset)
(RD.SUBFNS reset)
(DONTCOMPILEFNS reset)
(INEWCOMS reset)
(EXPANDMACROFNS reset)
(MKI.SUBFNS reset)
(RD.SUBFNS reset)
(INEWCOMS reset)
(DONTCOMPILEFNS reset)

{DSK}<tilde>sybalsky>lispcore>sources>LLBASIC.;13
File created 31-Jan-98 09:55:50
LLBASICCOMS
(DONTCOMPILEFNS reset)
(INITVALUES reset)
(INITPTRS reset)
(INEWCOMS reset)
(EXPANDMACROFNS reset)
(MKI.SUBFNS reset)
(RD.SUBFNS reset)
(RDCOMS reset)

{DSK}<tilde>sybalsky>lispcore>sources>LLDATATYPE.;12
File created 28-Jun-99 16:57:50
LLDATATYPECOMS
(INITVALUES reset)
(INITPTRS reset)
(INEWCOMS reset)
(RDCOMS reset)
(RD.SUBFNS reset)
(EXPANDMACROFNS reset)
(MKI.SUBFNS reset)
(DONTCOMPILEFNS reset)
(new COPYRIGHT property for LLDATATYPE)

{DSK}<tilde>sybalsky>lispcore>sources>LLGC.;4
File created 19-Oct-94 12:30:11
LLGCCOMS
(MKI.SUBFNS reset)
(INEWCOMS reset)
(DONTCOMPILEFNS reset)

{DSK}<tilde>sybalsky>lispcore>sources>LLSTK.;1
File created  6-Jan-93 18:07:37
LLSTKCOMS
(INEWCOMS reset)
(EXPANDMACROFNS reset)
(DONTCOMPILEFNS reset)
LLSTKCOMS
(LLSTKCOMS reset)
(LAMA reset)
(LAMA reset)

{DSK}<tilde>sybalsky>lispcore>sources>RENAMEMACROS.;3
File created 27-Apr-94 15:43:27
RENAMEMACROSCOMS

{DSK}<tilde>sybalsky>lispcore>sources>MODARITH.;1
File created 16-May-90 20:46:21
MODARITHCOMS
(EXPANDMACROFNS reset)

{DSK}<tilde>sybalsky>lispcore>sources>LLFAULT.;1
File created  2-Jan-93 12:26:58
LLFAULTCOMS
(INEWCOMS reset)
(RDCOMS reset)
(EXPANDMACROFNS reset)
(MKI.SUBFNS reset)
(RD.SUBFNS reset)
(DONTCOMPILEFNS reset)
(INEWCOMS reset)
LLFAULTCOMS
(LLFAULTCOMS reset)
(LAMA reset)
(LAMA reset)

{DSK}<tilde>sybalsky>lispcore>sources>LLKEY.;7
File created  9-Apr-2000 16:28:23
LLKEYCOMS
(INEWCOMS reset)
(RDCOMS reset)
(new COPYRIGHT property for LLKEY)
(NLAML reset)
(LAMA reset)

{DSK}<tilde>sybalsky>lispcore>sources>LLBFS.;1
File created 17-Dec-92 01:31:53
LLBFSCOMS
(INITPTRS reset)
(INEWCOMS reset)
(DONTCOMPILEFNS reset)
(INEWCOMS reset)

{DSK}<tilde>sybalsky>lispcore>sources>LLTIMER.;1
File created 16-May-90 20:13:11
LLTIMERCOMS
(INEWCOMS reset)
(\TIMEREXPIRED.BOX reset)
New fns definition for \SETUPTIMERmacrofn.
listing? F
(I.MAKEINITBFS NIL (uses I.FREEPAGEFID I.DISKREQUESTBLOCK I.SWAPREQUESTBLOCK I.SWAPDSK2 I.SWAPDSK1 I.MAINDISK))
(I.\\LOCKFN (FN))
(I.\\LOCKVAR (VAR))
(I.\\LOCKCELL (X NPGS))
(I.\\LOCKWORDS (BASE NWORDS))
(I.\\LOCKCODE (CODEBLOCK))
(I.DUMPINITPAGES (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (uses |MKI.Page0Byte| NEXTVMEM NEXTPM))
(I.SETUPPAGEMAP NIL (uses NEXTVMEM NEXTPM))
(I.ADDPME (VP NEWPAGEOK) (uses NEXTVMEM NEXTPM))
(I.MAKEROOMFORPME (VP) (uses NEXTPM))
(I.MAPPAGES (BOT TOP FN))
(I.SETUPSTACK (INITFLG) (uses RESETPTR RESETPC))
(I.\\SETUPSTACK1 (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH))
(I.\\SETUPGUARDBLOCK (STKP LEN))
(I.\\MAKEFREEBLOCK (STK SIZE))
(I.INITGC NIL)
(I.NTYPX (X))
(I.\\ALLOCMDSPAGE (TYP) (uses |I.NxtMDSPage| I.MDSFREELISTPAGE))
(I.\\MAKEMDSENTRY (VP V))
(I.\\INITMDSPAGE (BASE SIZE PREV))
(I.\\ASSIGNDATATYPE1A0001 (PAGE))
(I.\\ASSIGNDATATYPE1 (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) (uses |I.MaxTypeNumber| |I.MaxSysTypeNum|))
(I.\\TYPENUMBERFROMNAME (TYPE) (uses |I.MaxTypeNumber|))
(I.\\CREATECELL (TYP))
(I.\\NEW2PAGE (BASE))
(I.CREATEMDSTYPETABLE NIL)
(I.INITDATATYPES NIL (uses |I.MaxTypeNumber| |I.MaxSysTypeNum| I.LISTPDTD INITIALDTDCONTENTS))
(I.INITDATATYPENAMES NIL (uses INITIALDTDCONTENTS I.FINALIZATION.FUNCTIONS))
(I.FSETVAL (ATM VAL))
(I.SETPROPLIST (ATM LST))
(I.PUTDEFN (FN CA SIZE) (uses OUTX RESETPC RESETPTR LOCKEDFNS))
(I.\\BLT (DBASE SBASE NWORDS))
(I.\\MKATOM (BASE OFFST LEN FATP NONNUMERICP) (uses \\ORIGREADTABLE |I.OneCharAtomBase|))
(I.\\CREATE.SYMBOL (BASE OFFSET LEN FATP FATCHARSEENP) (uses |I.AtomFrLst|))
(I.\\INITATOMPAGE (PN))
(I.\\MOVEBYTES (SBASE SBYTE DBASE DBYTE NBYTES))
(I.\\STKMIN (CODE CODEISBLOCK PRINT))
(I.COPYATOM (X) (uses I.SCRATCHSTRING))
(I.INITATOMS NIL (uses |I.OneCharAtomBase| I.SCRATCHSTRING))
(I.MAKEINITFIRST NIL)
(I.\\COPY (X))
(I.MAKEINITLASTA0001 (P A))
(I.MAKEINITLASTA0002 (V A))
(I.MAKEINITLAST (VERSIONS) (uses MKI.ATOMARRAY LOCKEDVARS MKI.PTRS MKI.VALUES INITPTRS INITVALUES MKI.CODESTARTOFFSET MKI.CODELASTPAGE MKI.TVHA MKI.PLHA))
(I.\\CONS.UFN (X Y) (uses I.LISTPDTD))
(I.\\MAIKO.CONS.UFN (X Y))
(I.\\INITCONSPAGE (BASE LINK))
(I.\\NEXTCONSPAGE NIL (uses I.LISTPDTD))
(I.\\GETBASEBYTE (PTR N))
(I.\\PUTBASEBYTE (PTR DISP BYTE))
(I.CREATEPAGES (VA N BLANKFLG LOCKFLG))
(I.\\NEW4PAGE (PTR))
(I.ALLOCSTRING (N INITCHAR OLD FATFLG))
(I.%COPY-ONED-ARRAY (LOCAL-ARRAY))
(I.%COPY-STRING-TO-ARRAY (LOCAL-STRING))
(I.\\#BLOCKDATACELLS (DATAWORD) (uses I.HUNKING?))
(I.\\PREFIXALIGNMENT? (ARLEN INITONPAGE ALIGN GCTYPE BASE))
(I.\\ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?))
-----In I.\\MAIKO.ALLOCBLOCK\:
*****((*) - |value| |of| |comment| |used?|)
(I.\\MAIKO.ALLOCBLOCK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.HUNKING?))
-----
(I.\\ALLOCBLOCK.NEW (ARLEN GCTYPE INITONPAGE ALIGN) (uses |I.NxtMDSPage|))
(I.\\MAKEFREEARRAYBLOCK (BLOCK LENGTH))
(I.\\MERGEBACKWARD (BASE))
(I.\\LINKBLOCK (BASE) (uses I.FREEBLOCKBUCKETS))
(I.\\ALLOCHUNK (NCELLS GCTYPE INITONPAGE ALIGN) (uses I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE))
(I.PREINITARRAYS NIL)
(I.POSTINITARRAYS (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (uses I.FREEBLOCKBUCKETS))
(I.FILEARRAYBASE NIL (uses |MKI.FirstDataByte| MKI.CODESTARTOFFSET))
(I.FILEBLOCKTRAILER (BLOCKINFO) (uses OUTX))
(I.FILECODEBLOCK (NCELLS INITONPAGE) (uses OUTX))
(I.FILEPATCHBLOCK (ARLEN) (uses OUTX))
(I.\\SETUP.HUNK.TYPENUMBERS NIL (uses \\BUILT-IN-SYSTEM-TYPES INITIALDTDCONTENTS))
(I.\\COMPUTE.HUNK.TYPEDECLS (SIZELST GCTYPE PREFIX))
(I.\\TURN.ON.HUNKING NIL (uses I.HUNKING? I.PTRHUNK.TYPENUM.TABLE I.CODEHUNK.TYPENUM.TABLE I.UNBOXEDHUNK.TYPENUM.TABLE))
(I.\\SETUP.TYPENUM.TABLE (SIZELST GCTYPE PREFIX) (uses INITIALDTDCONTENTS))
(I.DCODERD (FN) (uses I.CODERDTBL))
(I.INITUFNTABLE NIL)
(I.\\SETUFNENTRY (INDEX FN NARGS NEXTRA))

{DSK}<tilde>sybalsky>lispcore>sources>MEM.LCOM;3
compiled on 25-Jan-98 17:45:42
File created  5-Nov-92 15:57:00
MEMCOMS

{DSK}<tilde>sybalsky>lispcore>4-BYTE-ATOMS>I-NEW.LCOM;48
compiled on 10-Apr-2000 01:45:23
File created 10-Apr-2000 01:45:05
I-NEWCOMS
|{DSK}<tilde>sybalsky>lispcore>sources>PACKAGE-CONVERSION-TABLE.LCOM;2|
(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 "LISP" :INTERNAL) ("CL:"
 ("CL:FLG" "CL:MAKE-SYMBOL" "CL:COPY-SYMBOL" "CL:INTERN" "CL:MAKE-KEYWORD" 
"CL:GENTEMP" "CL:KEYWORDP") "LISP" :EXTERNAL) (":" NIL "KEYWORD" :EXTERNAL) (
"CONDITIONS::" NIL "CONDITIONS" :INTERNAL) ("CONDITIONS:" NIL "CONDITIONS" 
:EXTERNAL) ("XCL::" NIL "XCL" :INTERNAL) ("XCL:" NIL "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)))))
|{DSK}<tilde>sybalsky>lispcore>sources>LLFAULT.LCOM;7|
|{DSK}<tilde>sybalsky>lispcore>sources>LLSUBRS.LCOM;2|
(SETF-MACRO-FUNCTION (QUOTE MISCN) (QUOTE expand-MISCN))
(PUTPROP (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
optimize-MISCN) (GET (QUOTE MISCN) (QUOTE COMPILER:OPTIMIZER-LIST))))
(SETF-MACRO-FUNCTION (QUOTE USER-SUBR) (QUOTE expand-USER-SUBR))
(SETF-MACRO-FUNCTION (QUOTE SUBRCALL) (QUOTE expand-SUBRCALL))
(PUTPROP (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
optimize-SUBRCALL) (GET (QUOTE SUBRCALL) (QUOTE COMPILER:OPTIMIZER-LIST))))
|{DSK}<tilde>sybalsky>lispcore>sources>LLBFS.LCOM;2|
|{DSK}<tilde>sybalsky>lispcore>sources>LLNEW.LCOM;4|
|{DSK}<tilde>sybalsky>lispcore>sources>FILEIO.LCOM;3|
(/DECLAREDATATYPE (QUOTE STREAM) (QUOTE (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)) (QUOTE ((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))) (QUOTE 56))
(DEFPRINT (QUOTE STREAM) (FUNCTION \STREAM.DEFPRINT))
(DEFPRINT (QUOTE FDEV) (FUNCTION \FDEV.DEFPRINT))
(/DECLAREDATATYPE (QUOTE FDEV) (QUOTE (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)) (QUOTE ((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))) (QUOTE 106))
(/DECLAREDATATYPE (QUOTE EXTERNALFORMAT) (QUOTE (FLAG (BITS 2) (BITS 1) 
POINTER POINTER POINTER POINTER)) (QUOTE ((EXTERNALFORMAT 0 (FLAGBITS . 0)) (
EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 
0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) (
EXTERNALFORMAT 6 POINTER))) (QUOTE 8))
(\CREATE.JIS.EXTERNALFORMAT)
(\CREATE.SHIFTJIS.EXTERNALFORMAT)
(\CREATE.EUC.EXTERNALFORMAT)
(\CREATE.THROUGH.EXTERNALFORMAT)
(MAPC (QUOTE ((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS
 \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS))) (FUNCTION (LAMBDA (PAIR) (
PUTD (CADR PAIR) (GETD (CAR PAIR)) T))))
(\NULLDEVICE)
|{DSK}<tilde>sybalsky>lispcore>sources>IMAGEIO.LCOM;4|
(/DECLAREDATATYPE (QUOTE IMAGEOPS) (QUOTE (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)) (QUOTE ((
IMAGEOPS 0 POINTER) (IMAGEOPS 2 POINTER) (IMAGEOPS 4 POINTER) (IMAGEOPS 6 
POINTER) (IMAGEOPS 8 POINTER) (IMAGEOPS 10 POINTER) (IMAGEOPS 12 POINTER) (
IMAGEOPS 14 POINTER) (IMAGEOPS 16 POINTER) (IMAGEOPS 18 POINTER) (IMAGEOPS 20
 POINTER) (IMAGEOPS 22 POINTER) (IMAGEOPS 24 POINTER) (IMAGEOPS 26 POINTER) (
IMAGEOPS 28 POINTER) (IMAGEOPS 30 POINTER) (IMAGEOPS 32 POINTER) (IMAGEOPS 34
 POINTER) (IMAGEOPS 36 POINTER) (IMAGEOPS 38 POINTER) (IMAGEOPS 40 POINTER) (
IMAGEOPS 42 POINTER) (IMAGEOPS 44 POINTER) (IMAGEOPS 46 POINTER) (IMAGEOPS 48
 POINTER) (IMAGEOPS 50 POINTER) (IMAGEOPS 52 POINTER) (IMAGEOPS 54 POINTER) (
IMAGEOPS 56 POINTER) (IMAGEOPS 58 POINTER) (IMAGEOPS 60 POINTER) (IMAGEOPS 62
 POINTER) (IMAGEOPS 64 POINTER) (IMAGEOPS 66 POINTER) (IMAGEOPS 68 POINTER) (
IMAGEOPS 70 POINTER) (IMAGEOPS 72 POINTER) (IMAGEOPS 74 POINTER) (IMAGEOPS 76
 POINTER) (IMAGEOPS 78 POINTER) (IMAGEOPS 80 POINTER) (IMAGEOPS 82 POINTER) (
IMAGEOPS 84 POINTER) (IMAGEOPS 86 POINTER) (IMAGEOPS 88 POINTER) (IMAGEOPS 90
 POINTER) (IMAGEOPS 92 POINTER) (IMAGEOPS 94 POINTER))) (QUOTE 96))
(\IMAGEIOINIT)
(SETTOPVAL (QUOTE \DISPLAYSTREAMTYPES) (CONS (QUOTE DISPLAY) 
\COLORDISPLAYSTREAMTYPES))
(\DISPLAYINIT)
(\4DISPLAYINIT)
(\8DISPLAYINIT)
(\24DISPLAYINIT)
|{DSK}<tilde>sybalsky>lispcore>sources>LLBASIC.LCOM;12|
(PUTPROP (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
definline-ATOM) (GET (QUOTE ATOM) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
optimize-\ATOMCELL) (GET (QUOTE \ATOMCELL) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE optimize-GETPROPLIST) (GET (QUOTE GETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE optimize-SETPROPLIST) (GET (QUOTE SETPROPLIST) (QUOTE COMPILER:OPTIMIZER-LIST))))
|{DSK}<tilde>sybalsky>lispcore>sources>LLGC.LCOM;2|
(SETTOPVAL (QUOTE \GCTIME1) (CREATECELL \FIXP))
(SETTOPVAL (QUOTE \GCTIME2) (CREATECELL \FIXP))
|{DSK}<tilde>sybalsky>lispcore>sources>LLARRAYELT.LCOM;2|
(DEFPRINT (QUOTE HARRAYP) (QUOTE \HASHTABLE.DEFPRINT))
(/DECLAREDATATYPE (QUOTE HARRAYP) (QUOTE (WORD WORD POINTER FLAG POINTER WORD
 WORD POINTER POINTER POINTER)) (QUOTE ((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))) (QUOTE 14))
|{DSK}<tilde>sybalsky>lispcore>sources>LLINTERP.LCOM;7|
(MOVD? (QUOTE SETQ) (QUOTE SETN) NIL T)
(MOVD? (QUOTE FUNCTION) (QUOTE CL:FUNCTION) NIL T)
(SETTOPVAL (QUOTE COMPVARMACROHASH) (HASHARRAY 100))
|{DSK}<tilde>sybalsky>lispcore>sources>LLMVS.LCOM;2|
(XCL::SET-CONSTANTP (QUOTE CL:MULTIPLE-VALUES-LIMIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:MULTIPLE-VALUES-LIMIT)))
|{DSK}<tilde>sybalsky>lispcore>sources>DEFSTRUCT-RUN-TIME.LCOM;2|
(PROCLAIM (QUOTE (SPECIAL *PARSED-DEFSTRUCTS*)))
(OR (BOUNDP (QUOTE *PARSED-DEFSTRUCTS*)) (SETQ *PARSED-DEFSTRUCTS* (
IL:HASHARRAY 100)))
(IL:SETF-MACRO-FUNCTION (QUOTE PARSED-STRUCTURE) (QUOTE 
|expand-PARSED-STRUCTURE|))
(SET-SETF-INVERSE (QUOTE PARSED-STRUCTURE) (QUOTE SET-PARSED-STRUCTURE))
(IL:\\ASSIGNDATATYPE1 (QUOTE STRUCTURE-OBJECT) NIL 0)
(PROCLAIM (QUOTE (SPECIAL *DEFSTRUCT-INFO-CACHE*)))
(OR (BOUNDP (QUOTE *DEFSTRUCT-INFO-CACHE*)) (SETQ *DEFSTRUCT-INFO-CACHE* (
IL:HASHARRAY 100)))
(PROCLAIM (QUOTE (SPECIAL XCL:*PRINT-STRUCTURE*)))
(OR (BOUNDP (QUOTE XCL:*PRINT-STRUCTURE*)) (SETQ XCL:*PRINT-STRUCTURE* T))
(IL:SET-DOCUMENTATION (QUOTE XCL:*PRINT-STRUCTURE*) (QUOTE VARIABLE) 
"Flag indicating whether the contents of structures are to be printed.")
|{DSK}<tilde>sybalsky>lispcore>sources>SETF-RUNTIME.LCOM;2|
|{DSK}<tilde>sybalsky>lispcore>sources>CMLSEQBASICS.LCOM;2|
(SET-DOCUMENTATION (QUOTE CL:COPY-SEQ) (QUOTE CL:FUNCTION) 
"Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ.")
(SET-DOCUMENTATION (QUOTE CL:MAKE-SEQUENCE) (QUOTE CL:FUNCTION) 
"Make a sequnce of the specified type")
(SET-DOCUMENTATION (QUOTE CL:NREVERSE) (QUOTE CL:FUNCTION) 
"Returns a sequence of the same elements in reverse order (the argument is destroyed).")
(SET-DOCUMENTATION (QUOTE CL:REVERSE) (QUOTE CL:FUNCTION) 
"Returns a new sequence containing the same elements but in reverse order.")
(CL::SET-SETF-INVERSE (QUOTE CL:ELT) (QUOTE %%SETELT))
(CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SUBSEQ) (QUOTE CL::SUBSEQ-setf-expander))
|{DSK}<tilde>sybalsky>lispcore>sources>LLARITH.LCOM;2|
(CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) (
MIN.FIXP -2147483648) (\\SIGNBIT 32768))
|{DSK}<tilde>sybalsky>lispcore>sources>LLFLOAT.LCOM;2|
(SETTOPVAL (QUOTE MAX.FLOAT) (\INFINITY 0))
(SETTOPVAL (QUOTE MIN.FLOAT) (\INFINITY 1))
(MOVD? (QUOTE FGREATERP) (QUOTE FGTP))
(CL:PROCLAIM (QUOTE (CL:SPECIAL INTPOWERS)))
(OR (BOUNDP (QUOTE INTPOWERS)) (CL:SETQ INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10
))) (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)))
(SETF-MACRO-FUNCTION (QUOTE SPLIT8) (QUOTE expand-SPLIT8))
(\INIT.POWERS.OF.TEN)
|{DSK}<tilde>sybalsky>lispcore>sources>LLBIGNUM.LCOM;3|
(/DECLAREDATATYPE (QUOTE BIGNUM) (QUOTE (POINTER)) (QUOTE ((BIGNUM 0 POINTER)
)) (QUOTE 2))
(DEFPRINT (QUOTE BIGNUM) (QUOTE BIGNUM.DEFPRINT))
(SETTOPVAL (QUOTE \BIGNUM.BETA) (EXPT 2 14))
(SETTOPVAL (QUOTE \BIGNUM.BETA1) (SUB1 \BIGNUM.BETA))
(CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) (\BIGNUM.BETA1 (SUB1 
\BIGNUM.BETA)))
(\INITBIGNUMS)
|{DSK}<tilde>sybalsky>lispcore>sources>LLREAD.LCOM;2|
(Value of CHARACTERNAMES changed from ((INFINITY 8551)) to (("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)))
(\MAKE.JIS.TO.XCCS.CONV.TABLE)
|{DSK}<tilde>sybalsky>lispcore>sources>LLCHAR.LCOM;2|
(MOVD? (QUOTE STRING.EQUAL) (QUOTE STRING-EQUAL) NIL T)
(MOVD? (QUOTE STRING.EQUAL) (QUOTE CL::SIMPLE-STRING-EQUAL) NIL T)
(MOVD? (QUOTE CHARACTER) (QUOTE FCHARACTER) NIL T)
|{DSK}<tilde>sybalsky>lispcore>sources>LLSTK.LCOM;6|
|{DSK}<tilde>sybalsky>lispcore>4-BYTE-ATOMS>LLDATATYPE.LCOM;1|
(AND (EQ \MACHINETYPE \MAIKO) (MOVD (QUOTE \MAIKO.SET.STORAGE.STATE) (QUOTE 
\SET.STORAGE.STATE)))
(MOVD? (QUOTE FETCHFIELD) (QUOTE FFETCHFIELD) NIL T)
(MOVD? (QUOTE REPLACEFIELD) (QUOTE FREPLACEFIELD) NIL T)
(MOVD? (QUOTE REPLACEFIELDVAL) (QUOTE FREPLACEFIELDVAL) NIL T)
(PUTPROP (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
optimize-TYPENAMEP) (GET (QUOTE TYPENAMEP) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE optimize-\INSTANCE-P) (GET (QUOTE \INSTANCE-P) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE optimize-PUTBASEPTRX) (GET (QUOTE PUTBASEPTRX) (QUOTE COMPILER:OPTIMIZER-LIST))))
(CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP 
\STREAM \NEW-ATOM)
|{DSK}<tilde>sybalsky>lispcore>sources>IOCHAR.LCOM;2|
(MOVD? (QUOTE SETA) (QUOTE SETCASEARRAY))
(MOVD? (QUOTE ELT) (QUOTE GETCASEARRAY))
(SETTOPVAL (QUOTE \TRANSPARENT) (CASEARRAY))
(SETTOPVAL (QUOTE UPPERCASEARRAY) (UPPERCASEARRAY))
(PUTPROP (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE
 optimize-DATEFORMAT) (GET (QUOTE DATEFORMAT) (QUOTE COMPILER:OPTIMIZER-LIST)
)))
|{DSK}<tilde>sybalsky>lispcore>sources>LLKEY.LCOM;8|
(MOVD? (QUOTE NILL) (QUOTE CARET))
(CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2)
 (\TOSHIBA.JIS 7))
(\KEYBOARDINIT)
(PUTPROP (QUOTE \KEYNAMETONUMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN 
(QUOTE optimize-\KEYNAMETONUMBER) (GET (QUOTE \KEYNAMETONUMBER) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(\INIT.KEYBOARD.STREAM)
(CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16))
(MOVD (QUOTE CURSOR) (QUOTE SETCURSOR))
(MOVD (QUOTE \CURSORPOSITION) (QUOTE \SETCURSORPOSITION))
(SETTOPVAL (QUOTE \SFPosition) (CREATEPOSITION))
|{DSK}<tilde>sybalsky>lispcore>sources>LLTIMER.LCOM;2|
(PUTPROP (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
optimize-\RCLOCK0) (GET (QUOTE \RCLOCK0) (QUOTE COMPILER:OPTIMIZER-LIST))))
(SETTOPVAL (QUOTE \TIMEREXPIRED.BOX) (SETUPTIMER 0))
|{DSK}<tilde>sybalsky>lispcore>sources>ASTACK.LCOM;5|
|{DSK}<tilde>sybalsky>lispcore>sources>DTDECLARE.LCOM;6|
(PUTPROP (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE
 |optimize-FETCHFIELD|) (GET (QUOTE FETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE |optimize-FFETCHFIELD|) (GET (QUOTE FFETCHFIELD) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE REPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE |optimize-REPLACEFIELD|) (GET (QUOTE REPLACEFIELD) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE FREPLACEFIELD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE |optimize-FREPLACEFIELD|) (GET (QUOTE FREPLACEFIELD) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE REPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE |optimize-REPLACEFIELDVAL|) (GET (QUOTE REPLACEFIELDVAL) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE FREPLACEFIELDVAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN 
(QUOTE |optimize-FREPLACEFIELDVAL|) (GET (QUOTE FREPLACEFIELDVAL) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
|optimize-NCREATE|) (GET (QUOTE NCREATE) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
|optimize-\\DTEST|) (GET (QUOTE \\DTEST) (QUOTE COMPILER:OPTIMIZER-LIST))))
|{DSK}<tilde>sybalsky>lispcore>sources>ATBL.LCOM;2|
(/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 8 POINTER) (TERMTABLEP 10 POINTER) (TERMTABLEP 12 POINTER) (
TERMTABLEP 14 POINTER) (TERMTABLEP 14 (FLAGBITS . 0)) (TERMTABLEP 14 (
FLAGBITS . 16)))) (QUOTE 16))
(/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 . 16)) (READTABLEP 2 (FLAGBITS . 32)
) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 48)) (READTABLEP 0 (
FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 16)) (READTABLEP 0 (FLAGBITS . 32)) 
(READTABLEP 0 (FLAGBITS . 48)) (READTABLEP 4 (FLAGBITS . 80)) (READTABLEP 4 (
FLAGBITS . 96)) (READTABLEP 4 (FLAGBITS . 112)) (READTABLEP 6 POINTER) (
READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 135)) (READTABLEP 4 (BITS . 
135)) (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER))) (QUOTE 12))
(/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 8))
(\ATBLSET)
|{DSK}<tilde>sybalsky>lispcore>sources>LLCODE.LCOM;2|
(SETTOPVAL (QUOTE CODERDTBL) (COPYREADTABLE (QUOTE ORIG)))
(SETSYNTAX 25 (QUOTE (MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL))))) 
CODERDTBL)
(SETSYNTAX 124 (QUOTE (MACRO ALWAYS READVBAR)) CODERDTBL)
(READTABLEPROP CODERDTBL (QUOTE USESILPACKAGE) NIL)
(/DECLAREDATATYPE (QUOTE COMPILED-CLOSURE) (QUOTE (POINTER POINTER)) (QUOTE (
(COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER))) (QUOTE 4))
(DEFPRINT (QUOTE COMPILED-CLOSURE) (QUOTE \CCLOSURE.DEFPRINT))
|{DSK}<tilde>sybalsky>lispcore>sources>ACODE.LCOM;5|
|{DSK}<tilde>sybalsky>lispcore>sources>COREIO.LCOM;3|
(/DECLAREDATATYPE (QUOTE COREFILEINFOBLK) (QUOTE (FIXP FIXP FIXP POINTER 
POINTER POINTER WORD WORD (BITS 2) WORD)) (QUOTE ((COREFILEINFOBLK 0 FIXP) (
COREFILEINFOBLK 2 FIXP) (COREFILEINFOBLK 4 FIXP) (COREFILEINFOBLK 6 POINTER) 
(COREFILEINFOBLK 8 POINTER) (COREFILEINFOBLK 10 POINTER) (COREFILEINFOBLK 12 
(BITS . 15)) (COREFILEINFOBLK 13 (BITS . 15)) (COREFILEINFOBLK 10 (BITS . 1))
 (COREFILEINFOBLK 14 (BITS . 15)))) (QUOTE 16))
(COREDEVICE (QUOTE NODIRCORE) T)
(COREDEVICE (QUOTE CORE))
(COREDEVICE (QUOTE SCRATCH) T)
|{DSK}<tilde>sybalsky>lispcore>sources>AOFD.LCOM;2|
(\BASEBYTES.IO.INIT)
(\STRINGSTREAM.INIT)
|{DSK}<tilde>sybalsky>lispcore>sources>ADIR.LCOM;2|
(CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T))
(MOVD? (QUOTE SIMPLE.FINDFILE) (QUOTE FINDFILE) NIL T)
(MOVD? (QUOTE NILL) (QUOTE CL:PATHNAMEP))
|{DSK}<tilde>sybalsky>lispcore>sources>PMAP.LCOM;2|
(PUTD (QUOTE \PAGEDBIN) (GETD (QUOTE \BUFFERED.BIN)) T)
(PUTD (QUOTE \PAGEDPEEKBIN) (GETD (QUOTE \BUFFERED.PEEKBIN)) T)
(/DECLAREDATATYPE (QUOTE BUFFER) (QUOTE (POINTER XPOINTER POINTER POINTER 
FLAG FLAG FLAG)) (QUOTE ((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 
POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 
16)) (BUFFER 6 (FLAGBITS . 32)))) (QUOTE 8))
|{DSK}<tilde>sybalsky>lispcore>sources>VANILLADISK.LCOM;2|
(\\VANILLADISKINIT)
|{DSK}<tilde>sybalsky>lispcore>sources>MOD44IO.LCOM;2|
|{DSK}<tilde>sybalsky>lispcore>sources>ATERM.LCOM;2|
(\INITBCPLDISPLAY)
(MOVD? (QUOTE NILL) (QUOTE SETDISPLAYHEIGHT))
(MOVD? (QUOTE \OPENLINEBUF) (QUOTE \CREATE.TTYDISPLAYSTREAM))
(SETTOPVAL (QUOTE \DEFAULTLINEBUF) (\SETUP.DEFAULT.LINEBUF))
(\OPENLINEBUF)
|{DSK}<tilde>sybalsky>lispcore>sources>APRINT.LCOM;2|
(SETTOPVAL (QUOTE \PNAMEDEVICE) (NCREATE (QUOTE FDEV) (\GETDEVICEFROMHOSTNAME
 (QUOTE NULL) T)))
(PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE
 DMACRO (= . PROG1)))
|{DSK}<tilde>sybalsky>lispcore>sources>ABASIC.LCOM;2|
(DUMMYDEF (WINDOWWORLDP NILL))
(SETTOPVAL (QUOTE \IMAX.FLOAT) (FIX MAX.FLOAT))
(SETTOPVAL (QUOTE \IMIN.FLOAT) (FIX MIN.FLOAT))
|{DSK}<tilde>sybalsky>lispcore>sources>AERROR.LCOM;2|
(CL:PROCLAIM (QUOTE (CL:SPECIAL *LAST-CONDITION*)))
(OR (BOUNDP (QUOTE *LAST-CONDITION*)) (CL:SETQ *LAST-CONDITION* NIL))
(SET-DOCUMENTATION (QUOTE *LAST-CONDITION*) (QUOTE CL:VARIABLE) 
"Last condition signalled. This gets rebound to itself in nested execs.")
|{DSK}<tilde>sybalsky>lispcore>sources>AINTERRUPT.LCOM;2|
(INTCHAR T)
(SETTOPVAL (QUOTE LAST^TTIMEBOX) (CLOCK 0))
|{DSK}<tilde>sybalsky>lispcore>sources>MISC.LCOM;2|
(SETTOPVAL (QUOTE \GS.STR) (ALLOCSTRING 0))
(CL:PROCLAIM (QUOTE (GLOBAL MAKESYSDATE MAKESYSNAME)))
|{DSK}<tilde>sybalsky>lispcore>sources>BOOTSTRAP.LCOM;2|
(SETTOPVAL (QUOTE EOLCHARCODE) (CHCON1 "
"))
(Value of PRETTYHEADER changed from NIL to "File created ")
(MAPC (QUOTE ((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) (NILL . 
RESETRESTORE))) (FUNCTION (LAMBDA (X) (OR (CCODEP (CDR X)) (MOVD (CAR X) (CDR
 X) NIL T)))))
(AND (CCODEP (QUOTE BOOTSTRAP-NAMEFIELD)) (PUTD (QUOTE BOOTSTRAP-NAMEFIELD)))
(RADIX 10)
|{DSK}<tilde>sybalsky>lispcore>sources>CMLMACROS.LCOM;2|
(APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO)
(SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET))
(CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION))
|{DSK}<tilde>sybalsky>lispcore>sources>CMLEVAL.LCOM;2|
(PUTPROP (QUOTE INTERLISP) (QUOTE SPECIAL-FORM) (QUOTE PROGN))
(CL:PROCLAIM (QUOTE (CL:SPECIAL *CHECK-ARGUMENT-COUNTS*)))
(CL:PROCLAIM (QUOTE (GLOBAL *SPECIAL-BINDING-MARK*)))
(OR (BOUNDP (QUOTE *SPECIAL-BINDING-MARK*)) (CL:SETQ *SPECIAL-BINDING-MARK* 
"Variable specially bound. This string should never be visible"))
(XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-LIST-KEYWORDS) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-LIST-KEYWORDS)))
(XCL::SET-CONSTANTP (QUOTE CL:CALL-ARGUMENTS-LIMIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CALL-ARGUMENTS-LIMIT)))
(XCL::SET-CONSTANTP (QUOTE CL:LAMBDA-PARAMETERS-LIMIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:LAMBDA-PARAMETERS-LIMIT)))
(CL::SET-PARSED-STRUCTURE (QUOTE CLOSURE) T (QUOTE (CL::PS CLOSURE 
MAKE-CLOSURE (FUNCTION ENVIRONMENT) CL::DATATYPE NIL NIL "CLOSURE-" (
MAKE-CLOSURE) CLOSURE-P (LAMBDA (CLOSURE STREAM) (LET ((*PRINT-RADIX* NIL)) (
CL:FORMAT STREAM "#<Interpreted closure @ ~O,~O>" (\\HILOC CLOSURE) (\\LOLOC 
CLOSURE)))) COPY-CLOSURE NIL 0 NIL ((FUNCTION NIL T NIL (CLOSURE 0 POINTER) 
CLOSURE-FUNCTION) (ENVIRONMENT NIL T NIL (CLOSURE 2 POINTER) 
CLOSURE-ENVIRONMENT)) NIL NIL (POINTER POINTER) NIL (:ACCESSOR :PREDICATE) 
NIL NIL NIL)))
(SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE CLOSURE) (QUOTE (POINTER POINTER)) (
QUOTE ((CLOSURE 0 POINTER) (CLOSURE 2 POINTER))) 4 (QUOTE CL::STRUCTURE-OBJECT))
(PUTPROP (QUOTE CLOSURE) (QUOTE :TYPE-EXPANDER) (QUOTE 
CL::TYPE-EXPAND-STRUCTURE))
(CL::ESTABLISH-PREDICATE (QUOTE CLOSURE))
(CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE CLOSURE))
(CL::SET-PARSED-STRUCTURE (QUOTE ENVIRONMENT) T (QUOTE (CL::PS ENVIRONMENT 
NIL (VARS FUNCTIONS BLOCKS TAGBODIES) CL::DATATYPE NIL NIL "ENVIRONMENT-" ((
\\MAKE-ENVIRONMENT NIL)) ENVIRONMENT-P (LAMBDA (ENV STREAM DEPTH) (DECLARE (
IGNORE DEPTH)) (LET ((*PRINT-RADIX* NIL)) (CL:FORMAT STREAM 
"#<Lexical Environment @ ~O,~O>" (\\HILOC ENV) (\\LOLOC ENV)))) 
\\COPY-ENVIRONMENT NIL 0 NIL ((VARS NIL T NIL (ENVIRONMENT 0 POINTER) 
ENVIRONMENT-VARS) (FUNCTIONS NIL T NIL (ENVIRONMENT 2 POINTER) 
ENVIRONMENT-FUNCTIONS) (BLOCKS NIL T NIL (ENVIRONMENT 4 POINTER) 
ENVIRONMENT-BLOCKS) (TAGBODIES NIL T NIL (ENVIRONMENT 6 POINTER) 
ENVIRONMENT-TAGBODIES)) NIL NIL (POINTER POINTER POINTER POINTER) NIL (
:ACCESSOR :PREDICATE) NIL NIL NIL)))
(SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE ENVIRONMENT) (QUOTE (POINTER POINTER 
POINTER POINTER)) (QUOTE ((ENVIRONMENT 0 POINTER) (ENVIRONMENT 2 POINTER) (
ENVIRONMENT 4 POINTER) (ENVIRONMENT 6 POINTER))) 8 (QUOTE CL::STRUCTURE-OBJECT))
(PUTPROP (QUOTE ENVIRONMENT) (QUOTE :TYPE-EXPANDER) (QUOTE 
CL::TYPE-EXPAND-STRUCTURE))
(CL::ESTABLISH-PREDICATE (QUOTE ENVIRONMENT))
(CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE ENVIRONMENT))
(SETF-MACRO-FUNCTION (QUOTE \\MAKE-CHILD-ENVIRONMENT) (QUOTE 
|expand-\\MAKE-CHILD-ENVIRONMENT|))
(SETF-MACRO-FUNCTION (QUOTE ARG-REF) (QUOTE |expand-ARG-REF|))
(PUTPROP (QUOTE CL:COMPILER-LET) (QUOTE SPECIAL-FORM) (QUOTE 
CL::|interpret-COMPILER-LET|))
(PUTPROP (QUOTE CL:MACROLET) (QUOTE SPECIAL-FORM) (QUOTE 
CL::|interpret-MACROLET|))
(PUTPROP (QUOTE CL:FLET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-FLET|))
(PUTPROP (QUOTE CL:LABELS) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LABELS|
))
(PUTPROP (QUOTE QUOTE) (QUOTE SPECIAL-FORM) (QUOTE CAR))
(PUTPROP (QUOTE THE) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THE|))
(PUTPROP (QUOTE CL:EVAL-WHEN) (QUOTE SPECIAL-FORM) (QUOTE 
CL::|interpret-EVAL-WHEN|))
(PUTPROP (QUOTE DECLARE) (QUOTE SPECIAL-FORM) (QUOTE FALSE))
(SETF-MACRO-FUNCTION (QUOTE CL:LOCALLY) (QUOTE CL::|expand-LOCALLY|))
(PUTPROP (QUOTE PROGN) (QUOTE SPECIAL-FORM) (QUOTE \\EVAL-PROGN))
(PUTPROP (QUOTE PROG1) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-PROG1|))
(SETF-MACRO-FUNCTION (QUOTE PROG1) (QUOTE CL::|expand-PROG1|))
(PUTPROP (QUOTE LET*) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET*|))
(PUTPROP (QUOTE LET) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-LET|))
(PUTPROP (QUOTE COND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-COND|))
(SETF-MACRO-FUNCTION (QUOTE COND) (QUOTE CL::|expand-COND|))
(PUTPROP (QUOTE CL:IF) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-IF|))
(SETF-MACRO-FUNCTION (QUOTE AND) (QUOTE CL::|expand-AND|))
(SETF-MACRO-FUNCTION (QUOTE OR) (QUOTE CL::|expand-OR|))
(PUTPROP (QUOTE AND) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-AND|))
(PUTPROP (QUOTE OR) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-OR|))
(PUTPROP (QUOTE CL:BLOCK) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-BLOCK|))
(SETF-MACRO-FUNCTION (QUOTE RETURN) (QUOTE CL::|expand-RETURN|))
(PUTPROP (QUOTE CL:RETURN-FROM) (QUOTE SPECIAL-FORM) (QUOTE 
CL::|interpret-RETURN-FROM|))
(PUTPROP (QUOTE CL:FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE 
CL::|interpret-FUNCTION|))
(PUTPROP (QUOTE FUNCTION) (QUOTE SPECIAL-FORM) (QUOTE |interpret-FUNCTION|))
(PUTPROP (QUOTE CL:MULTIPLE-VALUE-CALL) (QUOTE SPECIAL-FORM) (QUOTE 
CL::|interpret-MULTIPLE-VALUE-CALL|))
(PUTPROP (QUOTE CL:MULTIPLE-VALUE-PROG1) (QUOTE SPECIAL-FORM) (QUOTE 
CL::|interpret-MULTIPLE-VALUE-PROG1|))
(SET-DOCUMENTATION (QUOTE CL:EVALHOOK) (QUOTE CL:FUNCTION) 
"Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn.  Ignores these hooks once, for the top-level evaluation of Form.")
(SET-DOCUMENTATION (QUOTE CL:APPLYHOOK) (QUOTE CL:FUNCTION) 
"Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn.  Ignores these hooks once, for the top-level evaluation of Form.")
(CL:PROCLAIM (QUOTE (CL:SPECIAL *EVALHOOK*)))
(OR (BOUNDP (QUOTE *EVALHOOK*)) (CL:SETQ *EVALHOOK* NIL))
(CL:PROCLAIM (QUOTE (CL:SPECIAL *APPLYHOOK*)))
(OR (BOUNDP (QUOTE *APPLYHOOK*)) (CL:SETQ *APPLYHOOK* NIL))
(CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-EVALHOOK*)))
(OR (BOUNDP (QUOTE CL::*SKIP-EVALHOOK*)) (CL:SETQ CL::*SKIP-EVALHOOK* NIL))
(SET-DOCUMENTATION (QUOTE CL::*SKIP-EVALHOOK*) (QUOTE CL:VARIABLE) 
"Used with non-null *EVALHOOK* to suppress the use of the hook-function
  for one level of eval.")
(CL:PROCLAIM (QUOTE (CL:SPECIAL CL::*SKIP-APPLYHOOK*)))
(OR (BOUNDP (QUOTE CL::*SKIP-APPLYHOOK*)) (CL:SETQ CL::*SKIP-APPLYHOOK* NIL))
(SET-DOCUMENTATION (QUOTE CL::*SKIP-APPLYHOOK*) (QUOTE CL:VARIABLE) 
"Used with non-null *APPLYHOOK* to suppress the use of the hook function
  for one level of eval.")
(CL::SET-SETF-INVERSE (QUOTE CL:CONSTANTP) (QUOTE XCL::SET-CONSTANTP))
(PUTPROP (QUOTE CL:SETQ) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-SETQ|))
(PUTPROP (QUOTE SETQ) (QUOTE SPECIAL-FORM) (QUOTE |interpret-SETQ|))
(SETF-MACRO-FUNCTION (QUOTE SETQ) (QUOTE |expand-SETQ|))
(SETF-MACRO-FUNCTION (QUOTE CL:PSETQ) (QUOTE CL::|expand-PSETQ|))
(SETF-MACRO-FUNCTION (QUOTE SETQQ) (QUOTE |expand-SETQQ|))
(PUTPROP (QUOTE CL:CATCH) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-CATCH|))
(PUTPROP (QUOTE CL:THROW) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-THROW|))
(PUTPROP (QUOTE CL:UNWIND-PROTECT) (QUOTE SPECIAL-FORM) (QUOTE 
CL::|interpret-UNWIND-PROTECT|))
(SETF-MACRO-FUNCTION (QUOTE PROG) (QUOTE CL::|expand-PROG|))
(SETF-MACRO-FUNCTION (QUOTE PROG*) (QUOTE CL::|expand-PROG*|))
(PUTPROP (QUOTE GO) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-GO|))
(PUTPROP (QUOTE CL:TAGBODY) (QUOTE SPECIAL-FORM) (QUOTE CL::|interpret-TAGBODY|))
(CL:PROCLAIM (QUOTE (CL:SPECIAL *MACROEXPAND-HOOK*)))
(CL::SET-SETF-INVERSE (QUOTE XCL::DECL-SPECIFIER-P) (QUOTE 
XCL::SET-DECL-SPECIFIER-P))
(CL::SET-SETF-INVERSE (QUOTE XCL::GLOBALLY-NOTINLINE-P) (QUOTE 
XCL::SET-GLOBALLY-NOTINLINE-P))
|{DSK}<tilde>sybalsky>lispcore>sources>CMLPROGV.LCOM;4|
(PUTPROP (QUOTE CL:PROGV) (QUOTE SPECIAL-FORM) (QUOTE CL::interpret-PROGV))
|{DSK}<tilde>sybalsky>lispcore>sources>CMLSPECIALFORMS.LCOM;2|
(IL:SETF-MACRO-FUNCTION (QUOTE LOOP) (QUOTE |expand-LOOP|))
(IL:PUTPROP (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-IDENTITY|) (GET (QUOTE IDENTITY) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:SETF-MACRO-FUNCTION (QUOTE UNLESS) (QUOTE |expand-UNLESS|))
(IL:SETF-MACRO-FUNCTION (QUOTE WHEN) (QUOTE |expand-WHEN|))
(IL:SETF-MACRO-FUNCTION (QUOTE FLET) (QUOTE |expand-FLET|))
(IL:SETF-MACRO-FUNCTION (QUOTE LABELS) (QUOTE |expand-LABELS|))
(IL:SETF-MACRO-FUNCTION (QUOTE IL:SELECTQ) (QUOTE IL:|expand-SELECTQ|))
(IL:SETF-MACRO-FUNCTION (QUOTE DO) (QUOTE |expand-DO|))
(IL:SETF-MACRO-FUNCTION (QUOTE DO*) (QUOTE |expand-DO*|))
(IL:SETF-MACRO-FUNCTION (QUOTE DOLIST) (QUOTE |expand-DOLIST|))
(IL:SETF-MACRO-FUNCTION (QUOTE DOTIMES) (QUOTE |expand-DOTIMES|))
(IL:SETF-MACRO-FUNCTION (QUOTE CASE) (QUOTE |expand-CASE|))
(Property IL:* of IL:MACRO has been changed)
(PROCLAIM (QUOTE (SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*)))
(PROCLAIM (CONS (QUOTE SPECIAL) IL:SYSSPECVARS))
|{DSK}<tilde>sybalsky>lispcore>sources>LLRESTART.LCOM;2|
(CL::SET-PARSED-STRUCTURE (QUOTE RESTART) T (QUOTE (CL::PS RESTART 
MAKE-RESTART (IL:NAME IL:TAG IL:SELECTOR IL:TEST IL:REPORT INTERACTIVE-FN 
FUNCTION) CL::DATATYPE NIL NIL "RESTART-" (MAKE-RESTART) RESTART-P 
%RESTART-PRINTER COPY-RESTART NIL 0 NIL ((IL:NAME NIL T NIL (RESTART 0 
IL:POINTER) RESTART-NAME) (IL:TAG NIL T NIL (RESTART 2 IL:POINTER) 
RESTART-TAG) (IL:SELECTOR NIL T NIL (RESTART 4 IL:POINTER) RESTART-SELECTOR) 
(IL:TEST NIL T NIL (RESTART 6 IL:POINTER) RESTART-TEST) (IL:REPORT (QUOTE 
%RESTART-DEFAULT-REPORTER) T NIL (RESTART 8 IL:POINTER) RESTART-REPORT) (
INTERACTIVE-FN NIL T NIL (RESTART 10 IL:POINTER) RESTART-INTERACTIVE-FN) (
FUNCTION NIL T NIL (RESTART 12 IL:POINTER) RESTART-FUNCTION)) NIL NIL (
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)
 NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)))
(SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE RESTART) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((RESTART 0
 IL:POINTER) (RESTART 2 IL:POINTER) (RESTART 4 IL:POINTER) (RESTART 6 
IL:POINTER) (RESTART 8 IL:POINTER) (RESTART 10 IL:POINTER) (RESTART 12 
IL:POINTER))) 14 (QUOTE CL::STRUCTURE-OBJECT))
(IL:PUTPROP (QUOTE RESTART) (QUOTE :TYPE-EXPANDER) (QUOTE 
CL::TYPE-EXPAND-STRUCTURE))
(CL::ESTABLISH-PREDICATE (QUOTE RESTART))
(CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE RESTART))
|{DSK}<tilde>sybalsky>lispcore>sources>LLERROR.LCOM;2|
(MOVD? (QUOTE SIMPLE-FORMAT) (QUOTE CL:FORMAT))
(CL::SET-PARSED-STRUCTURE (QUOTE PROCEED-CASE) T (QUOTE (CL::PS PROCEED-CASE 
MAKE-PROCEED-CASE (NAME TAG SELECTOR TEST REPORT CONDITIONS::INTERACTIVE-FN 
CL:FUNCTION) CL::DATATYPE NIL CONDITIONS:RESTART "%PROCEED-CASE-" (
MAKE-PROCEED-CASE) PROCEED-CASE-P CONDITIONS::%RESTART-PRINTER 
COPY-PROCEED-CASE NIL 0 NIL ((NAME NIL T NIL (PROCEED-CASE 0 POINTER) 
%PROCEED-CASE-NAME) (TAG NIL T NIL (PROCEED-CASE 2 POINTER) %PROCEED-CASE-TAG
) (SELECTOR NIL T NIL (PROCEED-CASE 4 POINTER) %PROCEED-CASE-SELECTOR) (TEST 
NIL T NIL (PROCEED-CASE 6 POINTER) %PROCEED-CASE-TEST) (REPORT (QUOTE 
CONDITIONS::%RESTART-DEFAULT-REPORTER) T NIL (PROCEED-CASE 8 POINTER) 
%PROCEED-CASE-REPORT) (CONDITIONS::INTERACTIVE-FN NIL T NIL (PROCEED-CASE 10 
POINTER) %PROCEED-CASE-INTERACTIVE-FN) (CL:FUNCTION NIL T NIL (PROCEED-CASE 
12 POINTER) %PROCEED-CASE-FUNCTION)) NIL NIL (POINTER POINTER POINTER POINTER
 POINTER POINTER POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)))
(SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PROCEED-CASE) (QUOTE (POINTER POINTER
 POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PROCEED-CASE 0 POINTER) (
PROCEED-CASE 2 POINTER) (PROCEED-CASE 4 POINTER) (PROCEED-CASE 6 POINTER) (
PROCEED-CASE 8 POINTER) (PROCEED-CASE 10 POINTER) (PROCEED-CASE 12 POINTER)))
 14 (QUOTE CONDITIONS:RESTART))
(PUTPROP (QUOTE PROCEED-CASE) (QUOTE :TYPE-EXPANDER) (QUOTE 
CL::TYPE-EXPAND-STRUCTURE))
(CL::ESTABLISH-PREDICATE (QUOTE PROCEED-CASE))
(CL::ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PROCEED-CASE))
(CL:PROCLAIM (QUOTE (GLOBAL SI::NLSETQ-PROCEED-CASE)))
(SETTOPVAL (QUOTE SI::NLSETQ-PROCEED-CASE) (MAKE-PROCEED-CASE :NAME (QUOTE 
ABORT) :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET"))
(SET-DOCUMENTATION (QUOTE SI::NLSETQ-PROCEED-CASE) (QUOTE CL:VARIABLE) 
"The prototype proceed-case object for NLSETQ.")
|{DSK}<tilde>sybalsky>lispcore>sources>LLSYMBOL.LCOM;2|
(IL:MOVD (QUOTE IL:GETPROPLIST) (QUOTE SYMBOL-PLIST))
(PROCLAIM (QUOTE (SPECIAL *GENSYM-COUNTER*)))
(OR (BOUNDP (QUOTE *GENSYM-COUNTER*)) (SETQ *GENSYM-COUNTER* 0))
(PROCLAIM (QUOTE (SPECIAL *GENSYM-PREFIX*)))
(OR (BOUNDP (QUOTE *GENSYM-PREFIX*)) (SETQ *GENSYM-PREFIX* "G"))
(PROCLAIM (QUOTE (SPECIAL *GENTEMP-COUNTER*)))
(OR (BOUNDP (QUOTE *GENTEMP-COUNTER*)) (SETQ *GENTEMP-COUNTER* 0))
|{DSK}<tilde>sybalsky>lispcore>sources>LLPACKAGE.LCOM;3|
(IL:SETF-MACRO-FUNCTION (QUOTE IL:\\FATCHARSEENP) (QUOTE 
IL:|expand-\\FATCHARSEENP|))
(IL:SETF-MACRO-FUNCTION (QUOTE IL:\\PACKAGIFY) (QUOTE IL:|expand-\\PACKAGIFY|
))
(IL:SET-DOCUMENTATION (QUOTE IL:\\PACKAGIFY) (QUOTE FUNCTION) 
"If OBJ isn't already a package, turn the symbol or string into the package of that name.")
(IL:SETF-MACRO-FUNCTION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE 
IL:|expand-\\STRING-EQUALBASE|))
(IL:SET-DOCUMENTATION (QUOTE IL:\\STRING-EQUALBASE) (QUOTE FUNCTION) 
"Compare a string to another string, with the second given in base offset length form.")
(IL:SETF-MACRO-FUNCTION (QUOTE IL:NUMERIC-UPCASE) (QUOTE 
IL:|expand-NUMERIC-UPCASE|))
(IL:SET-DOCUMENTATION (QUOTE IL:APROPOS-SEARCH) (QUOTE FUNCTION) 
"The symbol to substring comparison macro for APROPOS and APROPOS-LIST.  The string is assumed to already be uppercase.")
(SET-PARSED-STRUCTURE (QUOTE PACKAGE-HASHTABLE) T (QUOTE (PS 
PACKAGE-HASHTABLE %MAKE-PACKAGE-HASHTABLE (TABLE HASH SIZE FREE DELETED) 
DATATYPE NIL NIL "PACKAGE-HASHTABLE-" (%MAKE-PACKAGE-HASHTABLE) 
PACKAGE-HASHTABLE-P PRINT-PACKAGE-HASHTABLE NIL NIL 0 NIL ((TABLE NIL T NIL (
PACKAGE-HASHTABLE 0 IL:POINTER) PACKAGE-HASHTABLE-TABLE) (HASH NIL T NIL (
PACKAGE-HASHTABLE 2 IL:POINTER) PACKAGE-HASHTABLE-HASH) (SIZE NIL T NIL (
PACKAGE-HASHTABLE 4 IL:POINTER) PACKAGE-HASHTABLE-SIZE) (FREE NIL T NIL (
PACKAGE-HASHTABLE 6 IL:POINTER) PACKAGE-HASHTABLE-FREE) (DELETED NIL T NIL (
PACKAGE-HASHTABLE 8 IL:POINTER) PACKAGE-HASHTABLE-DELETED)) NIL 
"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." (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL))
)
(SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE-HASHTABLE) (QUOTE (IL:POINTER
 IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE-HASHTABLE 0 
IL:POINTER) (PACKAGE-HASHTABLE 2 IL:POINTER) (PACKAGE-HASHTABLE 4 IL:POINTER)
 (PACKAGE-HASHTABLE 6 IL:POINTER) (PACKAGE-HASHTABLE 8 IL:POINTER))) 10 (
QUOTE STRUCTURE-OBJECT))
(IL:PUTPROP (QUOTE PACKAGE-HASHTABLE) (QUOTE :TYPE-EXPANDER) (QUOTE 
TYPE-EXPAND-STRUCTURE))
(ESTABLISH-PREDICATE (QUOTE PACKAGE-HASHTABLE))
(ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE-HASHTABLE))
(IL:SET-DOCUMENTATION (QUOTE PACKAGE-HASHTABLE) (QUOTE STRUCTURE) 
"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.")
(SET-PARSED-STRUCTURE (QUOTE PACKAGE) T (QUOTE (PS PACKAGE %MAKE-PACKAGE (
INDEX TABLES NAME NAMESYMBOL NICKNAMES USE-LIST USED-BY-LIST EXTERNAL-ONLY 
INTERNAL-SYMBOLS EXTERNAL-SYMBOLS SHADOWING-SYMBOLS) DATATYPE NIL NIL 
%PACKAGE- (%MAKE-PACKAGE) PACKAGEP PRINT-PACKAGE COPY-PACKAGE NIL 0 NIL ((
INDEX NIL T NIL (PACKAGE 0 IL:POINTER) %PACKAGE-INDEX) (TABLES (LIST NIL) T 
NIL (PACKAGE 2 IL:POINTER) %PACKAGE-TABLES) (NAME NIL T NIL (PACKAGE 4 
IL:POINTER) %PACKAGE-NAME) (NAMESYMBOL NIL T NIL (PACKAGE 6 IL:POINTER) 
%PACKAGE-NAMESYMBOL) (NICKNAMES NIL T NIL (PACKAGE 8 IL:POINTER) 
%PACKAGE-NICKNAMES) (USE-LIST NIL T NIL (PACKAGE 10 IL:POINTER) 
%PACKAGE-USE-LIST) (USED-BY-LIST NIL T NIL (PACKAGE 12 IL:POINTER) 
%PACKAGE-USED-BY-LIST) (EXTERNAL-ONLY NIL T NIL (PACKAGE 14 IL:POINTER) 
%PACKAGE-EXTERNAL-ONLY) (INTERNAL-SYMBOLS NIL T NIL (PACKAGE 16 IL:POINTER) 
%PACKAGE-INTERNAL-SYMBOLS) (EXTERNAL-SYMBOLS NIL T NIL (PACKAGE 18 IL:POINTER
) %PACKAGE-EXTERNAL-SYMBOLS) (SHADOWING-SYMBOLS NIL T NIL (PACKAGE 20 
IL:POINTER) %PACKAGE-SHADOWING-SYMBOLS)) NIL NIL (IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER 
IL:POINTER IL:POINTER) NIL (:ACCESSOR :PREDICATE) NIL NIL NIL)))
(SI::%STRUCTURE-DECLARE-DATATYPE (QUOTE PACKAGE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((PACKAGE 0 IL:POINTER) (PACKAGE 2 IL:POINTER) (PACKAGE 4 IL:POINTER) (PACKAGE 6 IL:POINTER) (PACKAGE 8 IL:POINTER) (
PACKAGE 10 IL:POINTER) (PACKAGE 12 IL:POINTER) (PACKAGE 14 IL:POINTER) (
PACKAGE 16 IL:POINTER) (PACKAGE 18 IL:POINTER) (PACKAGE 20 IL:POINTER))) 22 (
QUOTE STRUCTURE-OBJECT))
(IL:PUTPROP (QUOTE PACKAGE) (QUOTE :TYPE-EXPANDER) (QUOTE 
TYPE-EXPAND-STRUCTURE))
(ESTABLISH-PREDICATE (QUOTE PACKAGE))
(ESTABLISH-SETFS-AND-OPTIMIZERS (QUOTE PACKAGE))
(IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PACKAGE-HASHTABLE) (QUOTE FUNCTION) 
"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.")
(PROCLAIM (QUOTE (SPECIAL *PACKAGE*)))
(OR (BOUNDP (QUOTE *PACKAGE*)) (SETQ *PACKAGE* NIL))
(IL:SET-DOCUMENTATION (QUOTE *PACKAGE*) (QUOTE VARIABLE) 
"The current package, in which read symbols are intern'ed.")
(PROCLAIM (QUOTE (SPECIAL XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)))
(OR (BOUNDP (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*)) (SETQ 
XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* (QUOTE ("LISP" "INTERLISP" 
"XEROX-COMMON-LISP"))))
(IL:SET-DOCUMENTATION (QUOTE XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES*) (QUOTE 
VARIABLE) "Packages whose deletion requires confirmation.")
(PROCLAIM (QUOTE (XCL:GLOBAL IL:*LISP-PACKAGE*)))
(OR (BOUNDP (QUOTE IL:*LISP-PACKAGE*)) (SETQ IL:*LISP-PACKAGE* NIL))
(IL:SET-DOCUMENTATION (QUOTE IL:*LISP-PACKAGE*) (QUOTE VARIABLE) 
"Global for internal references to the lisp package.")
(PROCLAIM (QUOTE (XCL:GLOBAL IL:*KEYWORD-PACKAGE*)))
(OR (BOUNDP (QUOTE IL:*KEYWORD-PACKAGE*)) (SETQ IL:*KEYWORD-PACKAGE* NIL))
(IL:SET-DOCUMENTATION (QUOTE IL:*KEYWORD-PACKAGE*) (QUOTE VARIABLE) 
"Global for internal references to the keyword package.")
(PROCLAIM (QUOTE (XCL:GLOBAL IL:*INTERLISP-PACKAGE*)))
(OR (BOUNDP (QUOTE IL:*INTERLISP-PACKAGE*)) (SETQ IL:*INTERLISP-PACKAGE* NIL)
)
(IL:SET-DOCUMENTATION (QUOTE IL:*INTERLISP-PACKAGE*) (QUOTE VARIABLE) 
"Global for internal references to the interlisp package.")
(XCL::SET-CONSTANTP (QUOTE IL:HASHTABLE-SIZE-LIMIT) NIL)
(PROCLAIM (QUOTE (SI::CONSTANT IL:HASHTABLE-SIZE-LIMIT)))
(IL:SET-DOCUMENTATION (QUOTE IL:HASHTABLE-SIZE-LIMIT) (QUOTE VARIABLE) 
"The maximum (inclusive, prime) limit to the size of a hashtable.")
(PROCLAIM (QUOTE (SPECIAL IL:PACKAGE-REHASH-THRESHOLD)))
(IL:SET-DOCUMENTATION (QUOTE IL:PACKAGE-REHASH-THRESHOLD) (QUOTE VARIABLE) 
"The maximum density allowed in a package hashtable")
(XCL::SET-CONSTANTP (QUOTE IL:PRIME-HASHTABLE-SIZES) NIL)
(PROCLAIM (QUOTE (SI::CONSTANT IL:PRIME-HASHTABLE-SIZES)))
(IL:SET-DOCUMENTATION (QUOTE IL:PRIME-HASHTABLE-SIZES) (QUOTE VARIABLE) 
"Some valid (prime) hashtable sizes.")
(IL:SET-DOCUMENTATION (QUOTE MAKE-SYMBOL) (QUOTE FUNCTION) 
"Make an uninterned symbol.")
(PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-NAME*)))
(OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-NAME*)) (SETQ IL:*PACKAGE-FROM-NAME* (
IL:HASHARRAY 255 (QUOTE IL:ERROR) (QUOTE IL:STRINGHASHBITS) (QUOTE IL:STREQUAL))))
(IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-NAME*) (QUOTE VARIABLE) 
"An equal hashtable from package names to packages.")
(PROCLAIM (QUOTE (XCL:GLOBAL IL:*PACKAGE-FROM-INDEX*)))
(OR (BOUNDP (QUOTE IL:*PACKAGE-FROM-INDEX*)) (SETQ IL:*PACKAGE-FROM-INDEX* (
MAKE-ARRAY 256 (QUOTE :INITIAL-ELEMENT) NIL)))
(IL:SET-DOCUMENTATION (QUOTE IL:*PACKAGE-FROM-INDEX*) (QUOTE VARIABLE) 
"Index to package converter.")
(XCL::SET-CONSTANTP (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) NIL)
(PROCLAIM (QUOTE (SI::CONSTANT XCL:*TOTAL-PACKAGES-LIMIT*)))
(IL:SET-DOCUMENTATION (QUOTE XCL:*TOTAL-PACKAGES-LIMIT*) (QUOTE VARIABLE) 
"The total number of packages that the system may have (excluding the 'uninterned' package).")
(XCL::SET-CONSTANTP (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) NIL)
(PROCLAIM (QUOTE (SI::CONSTANT IL:*UNINTERNED-PACKAGE-INDEX*)))
(IL:SET-DOCUMENTATION (QUOTE IL:*UNINTERNED-PACKAGE-INDEX*) (QUOTE VARIABLE) 
"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 .")
(IL:SET-DOCUMENTATION (QUOTE IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (QUOTE 
FUNCTION) 
"Return the next free table index for a package.  Starts counting at 1 because 0 is for uninterned symbols.")
(IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH) (QUOTE IL:|expand-SYMBOL-HASH|
))
(IL:SET-DOCUMENTATION (QUOTE IL:SYMBOL-HASH) (QUOTE FUNCTION) 
"Returns the atom hash of the given string")
(IL:SETF-MACRO-FUNCTION (QUOTE IL:REHASH-FACTOR) (QUOTE 
IL:|expand-REHASH-FACTOR|))
(IL:SETF-MACRO-FUNCTION (QUOTE IL:SYMBOL-HASH-REPROBE) (QUOTE 
IL:|expand-SYMBOL-HASH-REPROBE|))
(IL:SETF-MACRO-FUNCTION (QUOTE IL:ENTRY-HASH) (QUOTE IL:|expand-ENTRY-HASH|))
(IL:SET-DOCUMENTATION (QUOTE IL:ENTRY-HASH) (QUOTE FUNCTION) 
"Compute a number from the sxhash of the pname and the length which must be between 2 and 255.")
(IL:SETF-MACRO-FUNCTION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE 
IL:|expand-COUNT-PACKAGE-HASHTABLE|))
(IL:SET-DOCUMENTATION (QUOTE IL:COUNT-PACKAGE-HASHTABLE) (QUOTE FUNCTION) 
"Return two values: free elements and total size.")
(IL:SET-DOCUMENTATION (QUOTE IL:ENTER-NEW-NICKNAMES) (QUOTE FUNCTION) 
"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.")
(IL:SET-DOCUMENTATION (QUOTE IL:MAKE-PRIME-HASHTABLE-SIZE) (QUOTE FUNCTION) 
"Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size.")
(IL:SET-DOCUMENTATION (QUOTE MAKE-PACKAGE) (QUOTE FUNCTION) 
"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.")
(IL:SET-DOCUMENTATION (QUOTE FIND-PACKAGE) (QUOTE FUNCTION) 
"Given a name, find the package with that name or nickname")
(IL:SET-DOCUMENTATION (QUOTE USE-PACKAGE) (QUOTE FUNCTION) 
"Make a package use (inherit) symbols from others.  Checks for name-conflicts.")
(IL:SET-DOCUMENTATION (QUOTE IN-PACKAGE) (QUOTE FUNCTION) 
"Like Make-Package, but also makes the created package current.")
(IL:SET-DOCUMENTATION (QUOTE XCL:PKG-GOTO) (QUOTE FUNCTION) 
"Like in-package, but confirms creation of new packages.")
(IL:SET-DOCUMENTATION (QUOTE RENAME-PACKAGE) (QUOTE FUNCTION) 
"Change the name if we can, blast any old nicknames and then add in any new ones.")
(IL:SET-DOCUMENTATION (QUOTE EXPORT) (QUOTE FUNCTION) 
"Make the symbols external in the package.")
(IL:SET-DOCUMENTATION (QUOTE UNEXPORT) (QUOTE FUNCTION) 
"Check that all symbols are available, then move from external to internal.")
(IL:SET-DOCUMENTATION (QUOTE IMPORT) (QUOTE FUNCTION) 
"Make the symbol internal in the package, noting name conflicts.")
(IL:SET-DOCUMENTATION (QUOTE SHADOWING-IMPORT) (QUOTE FUNCTION) 
"If a conflicting symbol is present, unintern it, otherwise just stick the symbol in.")
(IL:SET-DOCUMENTATION (QUOTE SHADOW) (QUOTE FUNCTION) 
"Hide the existing symbols with new ones in the package.")
(IL:SET-DOCUMENTATION (QUOTE UNUSE-PACKAGE) (QUOTE FUNCTION) 
"Remove some packages from the use (inherit) list of another package.")
(IL:SET-DOCUMENTATION (QUOTE LIST-ALL-PACKAGES) (QUOTE FUNCTION) 
"Return a list of the names of all existing packages.")
(IL:SET-DOCUMENTATION (QUOTE IL:ADD-SYMBOL) (QUOTE FUNCTION) 
"Add a symbol to a package hashtable.  The symbol is assumed not to be present.")
(IL:SETF-MACRO-FUNCTION (QUOTE IL:WITH-SYMBOL) (QUOTE IL:|expand-WITH-SYMBOL|
))
(IL:SET-DOCUMENTATION (QUOTE IL:WITH-SYMBOL) (QUOTE FUNCTION) 
"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.")
(IL:SET-DOCUMENTATION (QUOTE IL:INTERN*) (QUOTE FUNCTION) 
"If the symbol doesn't exist then create it, special-casing the keyword package.")
(IL:SET-DOCUMENTATION (QUOTE IL:FIND-SYMBOL*) (QUOTE FUNCTION) 
"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:SET-DOCUMENTATION (QUOTE INTERN) (QUOTE FUNCTION) 
"Intern the name in the package, returning a symbol.")
(IL:SET-DOCUMENTATION (QUOTE FIND-SYMBOL) (QUOTE FUNCTION) 
"Find a symbol with the given name in a package.")
(IL:SET-DOCUMENTATION (QUOTE IL:NUKE-SYMBOL) (QUOTE FUNCTION) 
"Mark a symbol in a package-hashtable deleted")
(IL:SET-DOCUMENTATION (QUOTE UNINTERN) (QUOTE FUNCTION) 
"Remove a symbol from a package.  If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol.")
(IL:SET-DOCUMENTATION (QUOTE IL:MOBY-UNINTERN) (QUOTE FUNCTION) 
"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.")
(IL:SETF-MACRO-FUNCTION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE 
|expand-DO-EXTERNAL-SYMBOLS|))
(IL:SET-DOCUMENTATION (QUOTE DO-EXTERNAL-SYMBOLS) (QUOTE FUNCTION) 
"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.")
(IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE 
XCL::|expand-DO-LOCAL-SYMBOLS|))
(IL:SET-DOCUMENTATION (QUOTE XCL:DO-LOCAL-SYMBOLS) (QUOTE FUNCTION) 
"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.")
(IL:SETF-MACRO-FUNCTION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE 
XCL::|expand-DO-INTERNAL-SYMBOLS|))
(IL:SET-DOCUMENTATION (QUOTE XCL:DO-INTERNAL-SYMBOLS) (QUOTE FUNCTION) 
"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.")
(IL:SETF-MACRO-FUNCTION (QUOTE DO-SYMBOLS) (QUOTE |expand-DO-SYMBOLS|))
(IL:SET-DOCUMENTATION (QUOTE DO-SYMBOLS) (QUOTE FUNCTION) 
"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.")
(IL:SETF-MACRO-FUNCTION (QUOTE DO-ALL-SYMBOLS) (QUOTE |expand-DO-ALL-SYMBOLS|
))
(IL:SET-DOCUMENTATION (QUOTE DO-ALL-SYMBOLS) (QUOTE FUNCTION) 
"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.")
(IL:SET-DOCUMENTATION (QUOTE FIND-ALL-SYMBOLS) (QUOTE FUNCTION) 
"Find every symbol in all packages with the given name.")
(IL:SET-DOCUMENTATION (QUOTE IL:BRIEFLY-DESCRIBE-SYMBOL) (QUOTE FUNCTION) 
"Short form description of a symbol.")
(IL:SET-DOCUMENTATION (QUOTE APROPOS) (QUOTE FUNCTION) 
"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:SET-DOCUMENTATION (QUOTE APROPOS-LIST) (QUOTE FUNCTION) 
"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.")
(IL:SET-DOCUMENTATION (QUOTE IL:FIND-EXACT-SYMBOL) (QUOTE FUNCTION) 
"True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL")
|{DSK}<tilde>sybalsky>lispcore>sources>PACKAGE-STARTUP.LCOM;2|
(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))
(SET-DOCUMENTATION (QUOTE CHECK-SYMBOL-NAMESTRING) (QUOTE CL:FUNCTION) 
"Check whether a symbol would rather be in a package.")
(SET-DOCUMENTATION (QUOTE \\NEW.READ.SYMBOL) (QUOTE CL:FUNCTION) 
"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.")
(SET-DOCUMENTATION (QUOTE \\NEW.MKATOM) (QUOTE CL:FUNCTION) 
"A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table.")
(CL:PROCLAIM (QUOTE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED)))
(OR (BOUNDP (QUOTE LITATOM-PACKAGE-CONVERSION-ENABLED)) (CL:SETQ 
LITATOM-PACKAGE-CONVERSION-ENABLED NIL))
(CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.VARS)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.FNNAMES)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.DECLARATORS)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.TYPENAMES)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.MACROS)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SPECIALFORMS)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.LAMBDA.LIST.KEYWORDS)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL CMLSYMBOLS.SHARED)))
(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 "LISP" :INTERNAL) ("CL:"
 ("CL:FLG" "CL:MAKE-SYMBOL" "CL:COPY-SYMBOL" "CL:INTERN" "CL:MAKE-KEYWORD" 
"CL:GENTEMP" "CL:KEYWORDP") "LISP" :EXTERNAL) (":" NIL "KEYWORD" :EXTERNAL) (
"CONDITIONS::" NIL "CONDITIONS" :INTERNAL) ("CONDITIONS:" NIL "CONDITIONS" 
:EXTERNAL) ("XCL::" NIL "XCL" :INTERNAL) ("XCL:" NIL "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)))))
(SET-DOCUMENTATION (QUOTE TRANSFER-SYMBOL) (QUOTE CL:FUNCTION) 
"Move the function and plist definition cells of a symbol onto another, leaving name and value alone.")
(SET-DOCUMENTATION (QUOTE INTERN-LITATOM) (QUOTE CL:FUNCTION) 
"Tag a litatom with a package.  Add it to the package hashtable.  Handle keywords appropriately.  Return the symbol.")
(SET-DOCUMENTATION (QUOTE PACKAGE-INIT) (QUOTE CL:FUNCTION) 
"Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system.")
(SET-DOCUMENTATION (QUOTE PACKAGE-CLEAR) (QUOTE CL:FUNCTION) 
"Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages.")
(SET-DOCUMENTATION (QUOTE PACKAGE-MAKE) (QUOTE CL:FUNCTION) 
"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.")
(SET-DOCUMENTATION (QUOTE PACKAGE-ENABLE) (QUOTE CL:FUNCTION) 
"Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly.")
(SET-DOCUMENTATION (QUOTE PACKAGE-DISABLE) (QUOTE CL:FUNCTION) 
"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 EQ) (QUOTE EQL))
(MOVD? (QUOTE LENGTH) (QUOTE CL:LENGTH))
(MOVD? (QUOTE ID) (QUOTE CL:IDENTITY))
(MOVD? (QUOTE ID) (QUOTE REMOVE-COMMENTS))
(PACKAGE-INIT)
|{DSK}<tilde>sybalsky>lispcore>sources>CONDITION-PACKAGE.LCOM;2|
(IL:SET-DOCUMENTATION (QUOTE CL::NATURALIZE) (QUOTE FUNCTION) 
"Make a symbol, possibly in source, be in source and citizen and export of destination.")
(PROCLAIM (QUOTE (XCL:GLOBAL *FUTURE-CITIZENS-OF-CONDITIONS*)))
(IL:SET-DOCUMENTATION (QUOTE *FUTURE-CITIZENS-OF-CONDITIONS*) (QUOTE VARIABLE
) 
"Current citizens of XCL that should be in CONDITIONS: do not change this list!!!")
(XCL:DEFPACKAGE "CONDITIONS" (:EXPORT *BREAK-ON-SIGNALS* HANDLER-CASE 
WITH-SIMPLE-RESTART RESTART-CASE RESTART-BIND COMPUTE-RESTARTS RESTART-NAME 
FIND-RESTART INVOKE-RESTART INVOKE-RESTART-INTERACTIVELY CONTINUE 
MUFFLE-WARNING INVOKE-DEBUGGER RESTART TYPE-ERROR-DATUM PROGRAM-ERROR 
FILE-ERROR FILE-ERROR-PATHNAME DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW 
FLOATING-POINT-UNDERFLOW))
(MAPC (FUNCTION DEFECT-FROM-XCL-TO-CONDITIONS) 
*FUTURE-CITIZENS-OF-CONDITIONS*)
|{DSK}<tilde>sybalsky>lispcore>sources>XCL-PACKAGE.LCOM;2|
(PROCLAIM (QUOTE (SPECIAL CL::FUTURE-CITIZENS-OF-XCL)))
(IL:SET-DOCUMENTATION (QUOTE CL::FUTURE-CITIZENS-OF-XCL) (QUOTE VARIABLE) 
"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") (:EXPORT ARGLIST SET-EXEC-TYPE SET-DEFAULT-EXEC-TYPE 
SYNONYM-STREAM-P SYNONYM-STREAM-SYMBOL FOLLOW-SYNONYM-STREAMS 
BROADCAST-STREAM-P BROADCAST-STREAM-STREAMS CONCATENATED-STREAM-P 
CONCATENATED-STREAM-STREAMS TWO-WAY-STREAM-P TWO-WAY-STREAM-INPUT-STREAM 
TWO-WAY-STREAM-OUTPUT-STREAM ECHO-STREAM-P ECHO-STREAM-INPUT-STREAM 
ECHO-STREAM-OUTPUT-STREAM STRING-STREAM-P OPEN-STREAM-P *CURRENT-CONDITION* 
*EVAL-FUNCTION* *EXEC-PROMPT* *DEBUGGER-PROMPT* MAKE-PROFILE RESTORE-PROFILE 
SAVE-PROFILE WITH-PROFILE COPY-PROFILE PROFILE-NAME PROFILE-P FIND-PROFILE 
LIST-ALL-PROFILES DEFPROFILE PROFILES *DEFAULT-PROFILE* *PROFILE* PACK PACK* 
*PRINT-STRUCTURE* DO-INTERNAL-SYMBOLS PKG-GOTO READ-CONFLICT 
READ-CONFLICT-NAME READ-CONFLICT-PACKAGES MISSING-EXTERNAL-SYMBOL 
MISSING-EXTERNAL-SYMBOL-NAME MISSING-EXTERNAL-SYMBOL-PACKAGE MISSING-PACKAGE 
MISSING-PACKAGE-PACKAGE-NAME MISSING-PACKAGE-SYMBOL-NAME 
MISSING-PACKAGE-EXTERNAL PACKAGE-ERROR PACKAGE-ERROR-PACKAGE SYMBOL-CONFLICT 
SYMBOL-CONFLICT-SYMBOLS USE-CONFLICT USE-CONFLICT-USED-PACKAGE 
EXPORT-CONFLICT EXPORT-CONFLICT-EXPORTED-SYMBOLS SYMBOL-COLON-ERROR 
ESCAPE-COLONS-PROCEED EXPORT-CONFLICT-PACAKGES EXPORT-MISSING 
EXPORT-MISSING-SYMBOLS IMPORT-CONFLICT UNINTERN-CONFLICT 
UNINTERN-CONFLICT-SYMBOL PREFER-CLSYM-PROCEED RETURN-CLSYM-PROCEED 
PREFER-ILSYM-PROCEED RETURN-ILSYM-PROCEED MAKE-EXTERNAL-PROCEED 
MAKE-INTERNAL-PROCEED NEW-PACKAGE-PROCEED UGLY-SYMBOL-PROCEED 
SHADOW-USE-CONFLICTS-PROCEED UNINTERN-USER-PROCEED UNINTERN-USEE-PROCEED 
UNINTERN-PROCEED IMPORT-PROCEED SHADOWING-IMPORT-PROCEED *TRACE-IO* 
HASH-TABLE-FULL HASH-TABLE-FULL-TABLE ATTEMPT-TO-CHANGE-CONSTANT 
ATTEMPT-TO-CHANGE-CONSTANT-NAME ATTEMPT-TO-RPLAC-NIL 
ATTEMPT-TO-RPLAC-NIL-NAME TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR 
SIMPLE-TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR-CULPRIT STREAM-NOT-OPEN 
STREAM-NOT-OPEN-STREAM SYMBOL-NAME-TOO-LONG SYMBOL-NAME-TOO-LONG-STREAM 
SYMBOL-HT-FULL ARRAY-SPACE-FULL DATA-TYPES-EXHAUSTED DEVICE-ERROR 
DEVICE-ERROR-DEVICE SIMPLE-DEVICE-ERROR SIMPLE-DEVICE-ERROR-DEVICE 
SIMPLE-DEVICE-ERROR-MESSAGE FS-ERROR FILE-WONT-OPEN FILE-WONT-OPEN-PATHNAME 
FS-RESOURCES-EXCEEDED FS-PROTECTION-VIOLATION ARITHMETIC-ERROR 
ARITHMETIC-ERROR-OPERATION ARITHMETIC-ERROR-OPERANDS FLOATING-OVERFLOW 
FLOATING-OVERFLOW-OPERATION FLOATING-OVERFLOW-OPERANDS FLOATING-UNDERFLOW 
FLOATING-UNDERFLOW-OPERATION FLOATING-UNDERFLOW-OPERANDS PATHNAME-ERROR 
PATHNAME-ERROR-PATHNAME FILE-NOT-FOUND FILE-NOT-FOUND-PATHNAME 
INVALID-PATHNAME INVALID-PATHNAME-PATHNAME CONTROL-E-INTERRUPT 
CONTROL-E-INTERRUPT-FUNCTION ASSERTION-FAILED ASSERTION-FAILED-FORMAT-STRING 
ASSERTION-FAILED-FORMAT-ARGUMENTS BAD-PROCEED-CASE BAD-PROCEED-CASE-NAME 
TYPE-MISMATCH TYPE-MISMATCH-EXPECTED-TYPE TYPE-MISMATCH-VALUE 
TYPE-MISMATCH-MESSAGE STORAGE-EXHAUSTED CREATE-TRACE-WINDOW UNBREAK-FUNCTION 
REBREAK-FUNCTION TRACE-FUNCTION *TRACE-LEVEL* *TRACE-LENGTH* *TRACE-VERBOSE* 
INNER REINSTALL-ADVICE ADVISE-FUNCTION UNADVISE-FUNCTION READVISE-FUNCTION 
ADVISED-FUNCTIONS DEFADVICE WITH-COLLECTION COLLECT ONCE-ONLY 
*SHORT-SITE-NAME* *LONG-SITE-NAME* DEFINER NAMED-PROGN COMPILE-DEFINER 
COMPILE-FORM FALSE FILE-ENVIRONMENTS DEFINE-FILE-ENVIRONMENT 
*BREAK-ON-SIGNALS* HANDLER-CASE WITH-SIMPLE-RESTART RESTART-CASE RESTART-BIND
 COMPUTE-RESTARTS RESTART-NAME FIND-RESTART INVOKE-RESTART 
INVOKE-RESTART-INTERACTIVELY CONTINUE MUFFLE-WARNING INVOKE-DEBUGGER RESTART 
TYPE-ERROR TYPE-ERROR-DATUM PROGRAM-ERROR FILE-ERROR FILE-ERROR-PATHNAME 
DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW 
ROW-MAJOR-AREF RECORD-FETCH RECORD-FFETCH RECORD-CREATE DEFINE-RECORD 
PACKAGE-PREFIX))
(IL:MAPC CL::FUTURE-CITIZENS-OF-XCL (QUOTE CL::DEFECT-FROM-IL-TO-XCL))
(CL::CHECK-ALL)
|{DSK}<tilde>sybalsky>lispcore>sources>PROC.LCOM;6|
(/DECLAREDATATYPE (QUOTE PROCESS) (QUOTE (WORD WORD BYTE POINTER BYTE POINTER
 BYTE POINTER FLAG FLAG FLAG FLAG 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)) (QUOTE ((PROCESS 0 
(BITS . 15)) (PROCESS 1 (BITS . 15)) (PROCESS 2 (BITS . 7)) (PROCESS 4 
POINTER) (PROCESS 3 (BITS . 7)) (PROCESS 6 POINTER) (PROCESS 3 (BITS . 135)) 
(PROCESS 8 POINTER) (PROCESS 8 (FLAGBITS . 0)) (PROCESS 8 (FLAGBITS . 16)) (
PROCESS 8 (FLAGBITS . 32)) (PROCESS 8 (FLAGBITS . 48)) (PROCESS 6 (FLAGBITS
 . 0)) (PROCESS 6 (FLAGBITS . 16)) (PROCESS 6 (FLAGBITS . 32)) (PROCESS 6 (
FLAGBITS . 48)) (PROCESS 10 POINTER) (PROCESS 12 POINTER) (PROCESS 14 POINTER
) (PROCESS 16 POINTER) (PROCESS 18 POINTER) (PROCESS 20 POINTER) (PROCESS 22 
POINTER) (PROCESS 24 POINTER) (PROCESS 26 POINTER) (PROCESS 28 POINTER) (
PROCESS 30 POINTER) (PROCESS 32 POINTER) (PROCESS 34 POINTER) (PROCESS 36 
POINTER) (PROCESS 38 POINTER) (PROCESS 40 POINTER) (PROCESS 42 POINTER) (
PROCESS 44 POINTER) (PROCESS 46 POINTER) (PROCESS 48 POINTER) (PROCESS 50 
POINTER) (PROCESS 52 POINTER) (PROCESS 54 POINTER) (PROCESS 56 POINTER) (
PROCESS 58 POINTER) (PROCESS 60 POINTER) (PROCESS 62 POINTER) (PROCESS 64 
POINTER))) (QUOTE 66))
(/DECLAREDATATYPE (QUOTE PROCESSQUEUE) (QUOTE (BYTE POINTER POINTER POINTER 
POINTER)) (QUOTE ((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) (
PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER))) (
QUOTE 10))
(SETTOPVAL (QUOTE \PROCESS.NAME.TABLE) (HASHARRAY 30 NIL (FUNCTION 
STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL)))
(MOVD? (QUOTE PROCESS.RETURN) (QUOTE KILL.ME) NIL T)
(/DECLAREDATATYPE (QUOTE EVENT) (QUOTE (FLAG (BITS 3) POINTER POINTER)) (
QUOTE ((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) (
EVENT 2 POINTER))) (QUOTE 4))
(/DECLAREDATATYPE (QUOTE MONITORLOCK) (QUOTE (FLAG FLAG (BITS 2) POINTER 
POINTER POINTER POINTER)) (QUOTE ((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK
 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) (
MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER))) (
QUOTE 8))
(SETTOPVAL (QUOTE \PROCTIMER.SCRATCH) (NCREATE (QUOTE FIXP)))
(DEFPRINT (QUOTE PROCESS) (FUNCTION \PROCESS.DEFPRINT))
(DEFPRINT (QUOTE EVENT) (FUNCTION \EVENT.DEFPRINT))
(DEFPRINT (QUOTE MONITORLOCK) (FUNCTION \MONITORLOCK.DEFPRINT))
(\PROCESS.INIT)
|{DSK}<tilde>sybalsky>lispcore>sources>CMLARRAY.LCOM;5|
(CL::SET-SETF-INVERSE (QUOTE XCL:ROW-MAJOR-AREF) (QUOTE CL::ROW-MAJOR-ASET))
(CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:AREF) (QUOTE CL::|AREF-setf-expander|
))
(CL::SET-SETF-METHOD-EXPANDER (QUOTE BIT) (QUOTE CL::|BIT-setf-expander|))
(CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:CHAR) (QUOTE CL::|CHAR-setf-expander|
))
(CL::SET-SETF-INVERSE (QUOTE CL:FILL-POINTER) (QUOTE SET-FILL-POINTER))
(CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SBIT) (QUOTE CL::|SBIT-setf-expander|
))
(CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SCHAR) (QUOTE CL::|SCHAR-setf-expander|))
(CL::SET-SETF-METHOD-EXPANDER (QUOTE CL:SVREF) (QUOTE CL::|SVREF-setf-expander|))
(PUTPROP (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::|optimize-AREF|) (GET (QUOTE CL:AREF) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
XCL::|optimize-ASET|) (GET (QUOTE ASET) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::|optimize-BIT|) (GET (QUOTE BIT) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::|optimize-CHAR|) (GET (QUOTE CL:CHAR) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::|optimize-SBIT|) (GET (QUOTE CL:SBIT) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::|optimize-SCHAR|) (GET (QUOTE CL:SCHAR) (QUOTE COMPILER:OPTIMIZER-LIST)))
)
(PUTPROP (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::|optimize-SVREF|) (GET (QUOTE CL:SVREF) (QUOTE COMPILER:OPTIMIZER-LIST)))
)
(XCL::SET-CONSTANTP (QUOTE CL:ARRAY-RANK-LIMIT) NIL)
(SETTOPVAL (QUOTE CL:ARRAY-RANK-LIMIT) (EXPT 2 7))
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-RANK-LIMIT)))
(XCL::SET-CONSTANTP (QUOTE CL:ARRAY-TOTAL-SIZE-LIMIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT)))
(XCL::SET-CONSTANTP (QUOTE CL:ARRAY-DIMENSION-LIMIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:ARRAY-DIMENSION-LIMIT)))
(CL:PROCLAIM (QUOTE (CL:SPECIAL *DEFAULT-PUSH-EXTENSION-SIZE*)))
(PUTPROP (QUOTE %ONED-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE |optimize-%ONED-ARRAY-P|) (GET (QUOTE %ONED-ARRAY-P) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE %TWOD-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE |optimize-%TWOD-ARRAY-P|) (GET (QUOTE %TWOD-ARRAY-P) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE %GENERAL-ARRAY-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN 
(QUOTE |optimize-%GENERAL-ARRAY-P|) (GET (QUOTE %GENERAL-ARRAY-P) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(/DECLAREDATATYPE (QUOTE GENERAL-ARRAY) (QUOTE ((BITS 4) POINTER FLAG FLAG 
FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER)) (QUOTE ((
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))) (QUOTE 10))
(/DECLAREDATATYPE (QUOTE ONED-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) 
FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP)) (QUOTE ((
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))) (QUOTE 8))
(/DECLAREDATATYPE (QUOTE TWOD-ARRAY) (QUOTE ((BITS 4) POINTER FLAG (BITS 1) 
FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP)) (QUOTE ((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))) (QUOTE 10))
(DEFPRINT (QUOTE ONED-ARRAY) (QUOTE %DEFPRINT-VECTOR))
(DEFPRINT (QUOTE TWOD-ARRAY) (QUOTE %DEFPRINT-ARRAY))
(DEFPRINT (QUOTE GENERAL-ARRAY) (QUOTE %DEFPRINT-ARRAY))
(PUTPROP (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE |optimize-%ARRAY-READ|) (GET (QUOTE %ARRAY-READ) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE %ARRAY-WRITE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE |optimize-%ARRAY-WRITE|) (GET (QUOTE %ARRAY-WRITE) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
|{DSK}<tilde>sybalsky>lispcore>sources>DSK.LCOM;2|
(SETTOPVAL (QUOTE \DSKtopMonitor) (CREATE.MONITORLOCK "DSKTopMonitor"))
|{DSK}<tilde>sybalsky>lispcore>sources>UFS.LCOM;4|
(SETTOPVAL (QUOTE \UFStopMonitor) (CREATE.MONITORLOCK "UFSTopMonitor"))
(/DECLAREDATATYPE (QUOTE UFSGENFILESTATE) (QUOTE (FIXP FIXP FIXP POINTER 
POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP POINTER 
POINTER POINTER)) (QUOTE ((UFSGENFILESTATE 0 FIXP) (UFSGENFILESTATE 2 FIXP) (
UFSGENFILESTATE 4 FIXP) (UFSGENFILESTATE 6 POINTER) (UFSGENFILESTATE 8 
POINTER) (UFSGENFILESTATE 8 (FLAGBITS . 0)) (UFSGENFILESTATE 10 POINTER) (
UFSGENFILESTATE 12 FIXP) (UFSGENFILESTATE 14 POINTER) (UFSGENFILESTATE 16 
FIXP) (UFSGENFILESTATE 18 FIXP) (UFSGENFILESTATE 20 FIXP) (UFSGENFILESTATE 22
 FIXP) (UFSGENFILESTATE 24 POINTER) (UFSGENFILESTATE 26 FIXP) (
UFSGENFILESTATE 28 POINTER) (UFSGENFILESTATE 30 POINTER) (UFSGENFILESTATE 32 
POINTER))) (QUOTE 34))
(SETTOPVAL (QUOTE \UFS.GFS.TABLE) (HASHARRAY 20))
|{DSK}<tilde>sybalsky>lispcore>sources>UFSCALLC.LCOM;2|
|{DSK}<tilde>sybalsky>lispcore>sources>LLETHER.LCOM;2|
(/DECLAREDATATYPE (QUOTE SYSQUEUE) (QUOTE (BYTE POINTER BYTE POINTER)) (QUOTE
 ((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) (
SYSQUEUE 4 POINTER))) (QUOTE 6))
(/DECLAREDATATYPE (QUOTE ETHERPACKET) (QUOTE (BYTE POINTER BYTE POINTER BYTE 
POINTER FLAG FLAG (BITS 6) POINTER BYTE POINTER BYTE POINTER WORD WORD FIXP 
POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD
 WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
WORD WORD)) (QUOTE ((ETHERPACKET 0 (BITS . 7)) (ETHERPACKET 2 POINTER) (
ETHERPACKET 1 (BITS . 7)) (ETHERPACKET 4 POINTER) (ETHERPACKET 1 (BITS . 135)
) (ETHERPACKET 6 POINTER) (ETHERPACKET 6 (FLAGBITS . 0)) (ETHERPACKET 6 (
FLAGBITS . 16)) (ETHERPACKET 0 (BITS . 133)) (ETHERPACKET 8 POINTER) (
ETHERPACKET 10 (BITS . 7)) (ETHERPACKET 12 POINTER) (ETHERPACKET 11 (BITS . 7
)) (ETHERPACKET 14 POINTER) (ETHERPACKET 16 (BITS . 15)) (ETHERPACKET 17 (
BITS . 15)) (ETHERPACKET 18 FIXP) (ETHERPACKET 20 POINTER) (ETHERPACKET 22 (
BITS . 15)) (ETHERPACKET 23 (BITS . 15)) (ETHERPACKET 24 (BITS . 15)) (
ETHERPACKET 25 (BITS . 15)) (ETHERPACKET 26 (BITS . 15)) (ETHERPACKET 27 (
BITS . 15)) (ETHERPACKET 28 (BITS . 15)) (ETHERPACKET 29 (BITS . 15)) (
ETHERPACKET 30 (BITS . 15)) (ETHERPACKET 31 (BITS . 15)) (ETHERPACKET 32 (
BITS . 15)) (ETHERPACKET 33 (BITS . 15)) (ETHERPACKET 34 (BITS . 15)) (
ETHERPACKET 35 (BITS . 15)) (ETHERPACKET 36 (BITS . 15)) (ETHERPACKET 37 (
BITS . 15)) (ETHERPACKET 38 (BITS . 15)) (ETHERPACKET 39 (BITS . 15)) (
ETHERPACKET 40 (BITS . 15)) (ETHERPACKET 41 (BITS . 15)) (ETHERPACKET 42 (
BITS . 15)) (ETHERPACKET 43 (BITS . 15)) (ETHERPACKET 44 (BITS . 15)) (
ETHERPACKET 45 (BITS . 15)) (ETHERPACKET 46 (BITS . 15)) (ETHERPACKET 47 (
BITS . 15)) (ETHERPACKET 48 (BITS . 15)) (ETHERPACKET 49 (BITS . 15)) (
ETHERPACKET 50 (BITS . 15)) (ETHERPACKET 51 (BITS . 15)) (ETHERPACKET 52 (
BITS . 15)) (ETHERPACKET 53 (BITS . 15)) (ETHERPACKET 54 (BITS . 15)) (
ETHERPACKET 55 (BITS . 15)) (ETHERPACKET 56 (BITS . 15)) (ETHERPACKET 57 (
BITS . 15)) (ETHERPACKET 58 (BITS . 15)) (ETHERPACKET 59 (BITS . 15)) (
ETHERPACKET 60 (BITS . 15)) (ETHERPACKET 61 (BITS . 15)) (ETHERPACKET 62 (
BITS . 15)) (ETHERPACKET 63 (BITS . 15)) (ETHERPACKET 64 (BITS . 15)) (
ETHERPACKET 65 (BITS . 15)) (ETHERPACKET 66 (BITS . 15)) (ETHERPACKET 67 (
BITS . 15)) (ETHERPACKET 68 (BITS . 15)) (ETHERPACKET 69 (BITS . 15)) (
ETHERPACKET 70 (BITS . 15)) (ETHERPACKET 71 (BITS . 15)) (ETHERPACKET 72 (
BITS . 15)) (ETHERPACKET 73 (BITS . 15)) (ETHERPACKET 74 (BITS . 15)) (
ETHERPACKET 75 (BITS . 15)) (ETHERPACKET 76 (BITS . 15)) (ETHERPACKET 77 (
BITS . 15)) (ETHERPACKET 78 (BITS . 15)) (ETHERPACKET 79 (BITS . 15)) (
ETHERPACKET 80 (BITS . 15)) (ETHERPACKET 81 (BITS . 15)) (ETHERPACKET 82 (
BITS . 15)) (ETHERPACKET 83 (BITS . 15)) (ETHERPACKET 84 (BITS . 15)) (
ETHERPACKET 85 (BITS . 15)) (ETHERPACKET 86 (BITS . 15)) (ETHERPACKET 87 (
BITS . 15)) (ETHERPACKET 88 (BITS . 15)) (ETHERPACKET 89 (BITS . 15)) (
ETHERPACKET 90 (BITS . 15)) (ETHERPACKET 91 (BITS . 15)) (ETHERPACKET 92 (
BITS . 15)) (ETHERPACKET 93 (BITS . 15)) (ETHERPACKET 94 (BITS . 15)) (
ETHERPACKET 95 (BITS . 15)) (ETHERPACKET 96 (BITS . 15)) (ETHERPACKET 97 (
BITS . 15)) (ETHERPACKET 98 (BITS . 15)) (ETHERPACKET 99 (BITS . 15)) (
ETHERPACKET 100 (BITS . 15)) (ETHERPACKET 101 (BITS . 15)) (ETHERPACKET 102 (
BITS . 15)) (ETHERPACKET 103 (BITS . 15)) (ETHERPACKET 104 (BITS . 15)) (
ETHERPACKET 105 (BITS . 15)) (ETHERPACKET 106 (BITS . 15)) (ETHERPACKET 107 (
BITS . 15)) (ETHERPACKET 108 (BITS . 15)) (ETHERPACKET 109 (BITS . 15)) (
ETHERPACKET 110 (BITS . 15)) (ETHERPACKET 111 (BITS . 15)) (ETHERPACKET 112 (
BITS . 15)) (ETHERPACKET 113 (BITS . 15)) (ETHERPACKET 114 (BITS . 15)) (
ETHERPACKET 115 (BITS . 15)) (ETHERPACKET 116 (BITS . 15)) (ETHERPACKET 117 (
BITS . 15)) (ETHERPACKET 118 (BITS . 15)) (ETHERPACKET 119 (BITS . 15)) (
ETHERPACKET 120 (BITS . 15)) (ETHERPACKET 121 (BITS . 15)) (ETHERPACKET 122 (
BITS . 15)) (ETHERPACKET 123 (BITS . 15)) (ETHERPACKET 124 (BITS . 15)) (
ETHERPACKET 125 (BITS . 15)) (ETHERPACKET 126 (BITS . 15)) (ETHERPACKET 127 (
BITS . 15)) (ETHERPACKET 128 (BITS . 15)) (ETHERPACKET 129 (BITS . 15)) (
ETHERPACKET 130 (BITS . 15)) (ETHERPACKET 131 (BITS . 15)) (ETHERPACKET 132 (
BITS . 15)) (ETHERPACKET 133 (BITS . 15)) (ETHERPACKET 134 (BITS . 15)) (
ETHERPACKET 135 (BITS . 15)) (ETHERPACKET 136 (BITS . 15)) (ETHERPACKET 137 (
BITS . 15)) (ETHERPACKET 138 (BITS . 15)) (ETHERPACKET 139 (BITS . 15)) (
ETHERPACKET 140 (BITS . 15)) (ETHERPACKET 141 (BITS . 15)) (ETHERPACKET 142 (
BITS . 15)) (ETHERPACKET 143 (BITS . 15)) (ETHERPACKET 144 (BITS . 15)) (
ETHERPACKET 145 (BITS . 15)) (ETHERPACKET 146 (BITS . 15)) (ETHERPACKET 147 (
BITS . 15)) (ETHERPACKET 148 (BITS . 15)) (ETHERPACKET 149 (BITS . 15)) (
ETHERPACKET 150 (BITS . 15)) (ETHERPACKET 151 (BITS . 15)) (ETHERPACKET 152 (
BITS . 15)) (ETHERPACKET 153 (BITS . 15)) (ETHERPACKET 154 (BITS . 15)) (
ETHERPACKET 155 (BITS . 15)) (ETHERPACKET 156 (BITS . 15)) (ETHERPACKET 157 (
BITS . 15)) (ETHERPACKET 158 (BITS . 15)) (ETHERPACKET 159 (BITS . 15)) (
ETHERPACKET 160 (BITS . 15)) (ETHERPACKET 161 (BITS . 15)) (ETHERPACKET 162 (
BITS . 15)) (ETHERPACKET 163 (BITS . 15)) (ETHERPACKET 164 (BITS . 15)) (
ETHERPACKET 165 (BITS . 15)) (ETHERPACKET 166 (BITS . 15)) (ETHERPACKET 167 (
BITS . 15)) (ETHERPACKET 168 (BITS . 15)) (ETHERPACKET 169 (BITS . 15)) (
ETHERPACKET 170 (BITS . 15)) (ETHERPACKET 171 (BITS . 15)) (ETHERPACKET 172 (
BITS . 15)) (ETHERPACKET 173 (BITS . 15)) (ETHERPACKET 174 (BITS . 15)) (
ETHERPACKET 175 (BITS . 15)) (ETHERPACKET 176 (BITS . 15)) (ETHERPACKET 177 (
BITS . 15)) (ETHERPACKET 178 (BITS . 15)) (ETHERPACKET 179 (BITS . 15)) (
ETHERPACKET 180 (BITS . 15)) (ETHERPACKET 181 (BITS . 15)) (ETHERPACKET 182 (
BITS . 15)) (ETHERPACKET 183 (BITS . 15)) (ETHERPACKET 184 (BITS . 15)) (
ETHERPACKET 185 (BITS . 15)) (ETHERPACKET 186 (BITS . 15)) (ETHERPACKET 187 (
BITS . 15)) (ETHERPACKET 188 (BITS . 15)) (ETHERPACKET 189 (BITS . 15)) (
ETHERPACKET 190 (BITS . 15)) (ETHERPACKET 191 (BITS . 15)) (ETHERPACKET 192 (
BITS . 15)) (ETHERPACKET 193 (BITS . 15)) (ETHERPACKET 194 (BITS . 15)) (
ETHERPACKET 195 (BITS . 15)) (ETHERPACKET 196 (BITS . 15)) (ETHERPACKET 197 (
BITS . 15)) (ETHERPACKET 198 (BITS . 15)) (ETHERPACKET 199 (BITS . 15)) (
ETHERPACKET 200 (BITS . 15)) (ETHERPACKET 201 (BITS . 15)) (ETHERPACKET 202 (
BITS . 15)) (ETHERPACKET 203 (BITS . 15)) (ETHERPACKET 204 (BITS . 15)) (
ETHERPACKET 205 (BITS . 15)) (ETHERPACKET 206 (BITS . 15)) (ETHERPACKET 207 (
BITS . 15)) (ETHERPACKET 208 (BITS . 15)) (ETHERPACKET 209 (BITS . 15)) (
ETHERPACKET 210 (BITS . 15)) (ETHERPACKET 211 (BITS . 15)) (ETHERPACKET 212 (
BITS . 15)) (ETHERPACKET 213 (BITS . 15)) (ETHERPACKET 214 (BITS . 15)) (
ETHERPACKET 215 (BITS . 15)) (ETHERPACKET 216 (BITS . 15)) (ETHERPACKET 217 (
BITS . 15)) (ETHERPACKET 218 (BITS . 15)) (ETHERPACKET 219 (BITS . 15)) (
ETHERPACKET 220 (BITS . 15)) (ETHERPACKET 221 (BITS . 15)) (ETHERPACKET 222 (
BITS . 15)) (ETHERPACKET 223 (BITS . 15)) (ETHERPACKET 224 (BITS . 15)) (
ETHERPACKET 225 (BITS . 15)) (ETHERPACKET 226 (BITS . 15)) (ETHERPACKET 227 (
BITS . 15)) (ETHERPACKET 228 (BITS . 15)) (ETHERPACKET 229 (BITS . 15)) (
ETHERPACKET 230 (BITS . 15)) (ETHERPACKET 231 (BITS . 15)) (ETHERPACKET 232 (
BITS . 15)) (ETHERPACKET 233 (BITS . 15)) (ETHERPACKET 234 (BITS . 15)) (
ETHERPACKET 235 (BITS . 15)) (ETHERPACKET 236 (BITS . 15)) (ETHERPACKET 237 (
BITS . 15)) (ETHERPACKET 238 (BITS . 15)) (ETHERPACKET 239 (BITS . 15)) (
ETHERPACKET 240 (BITS . 15)) (ETHERPACKET 241 (BITS . 15)) (ETHERPACKET 242 (
BITS . 15)) (ETHERPACKET 243 (BITS . 15)) (ETHERPACKET 244 (BITS . 15)) (
ETHERPACKET 245 (BITS . 15)) (ETHERPACKET 246 (BITS . 15)) (ETHERPACKET 247 (
BITS . 15)) (ETHERPACKET 248 (BITS . 15)) (ETHERPACKET 249 (BITS . 15)) (
ETHERPACKET 250 (BITS . 15)) (ETHERPACKET 251 (BITS . 15)) (ETHERPACKET 252 (
BITS . 15)) (ETHERPACKET 253 (BITS . 15)) (ETHERPACKET 254 (BITS . 15)) (
ETHERPACKET 255 (BITS . 15)) (ETHERPACKET 256 (BITS . 15)) (ETHERPACKET 257 (
BITS . 15)) (ETHERPACKET 258 (BITS . 15)) (ETHERPACKET 259 (BITS . 15)) (
ETHERPACKET 260 (BITS . 15)) (ETHERPACKET 261 (BITS . 15)) (ETHERPACKET 262 (
BITS . 15)) (ETHERPACKET 263 (BITS . 15)) (ETHERPACKET 264 (BITS . 15)) (
ETHERPACKET 265 (BITS . 15)) (ETHERPACKET 266 (BITS . 15)) (ETHERPACKET 267 (
BITS . 15)) (ETHERPACKET 268 (BITS . 15)) (ETHERPACKET 269 (BITS . 15)) (
ETHERPACKET 270 (BITS . 15)) (ETHERPACKET 271 (BITS . 15)) (ETHERPACKET 272 (
BITS . 15)) (ETHERPACKET 273 (BITS . 15)) (ETHERPACKET 274 (BITS . 15)) (
ETHERPACKET 275 (BITS . 15)) (ETHERPACKET 276 (BITS . 15)) (ETHERPACKET 277 (
BITS . 15)) (ETHERPACKET 278 (BITS . 15)) (ETHERPACKET 279 (BITS . 15)) (
ETHERPACKET 280 (BITS . 15)) (ETHERPACKET 281 (BITS . 15)) (ETHERPACKET 282 (
BITS . 15)) (ETHERPACKET 283 (BITS . 15)) (ETHERPACKET 284 (BITS . 15)) (
ETHERPACKET 285 (BITS . 15)) (ETHERPACKET 286 (BITS . 15)) (ETHERPACKET 287 (
BITS . 15)) (ETHERPACKET 288 (BITS . 15)) (ETHERPACKET 289 (BITS . 15)) (
ETHERPACKET 290 (BITS . 15)) (ETHERPACKET 291 (BITS . 15)) (ETHERPACKET 292 (
BITS . 15)) (ETHERPACKET 293 (BITS . 15)) (ETHERPACKET 294 (BITS . 15)) (
ETHERPACKET 295 (BITS . 15)) (ETHERPACKET 296 (BITS . 15)) (ETHERPACKET 297 (
BITS . 15)) (ETHERPACKET 298 (BITS . 15)) (ETHERPACKET 299 (BITS . 15)) (
ETHERPACKET 300 (BITS . 15)) (ETHERPACKET 301 (BITS . 15)) (ETHERPACKET 302 (
BITS . 15)) (ETHERPACKET 303 (BITS . 15)) (ETHERPACKET 304 (BITS . 15)) (
ETHERPACKET 305 (BITS . 15)) (ETHERPACKET 306 (BITS . 15)) (ETHERPACKET 307 (
BITS . 15)) (ETHERPACKET 308 (BITS . 15)) (ETHERPACKET 309 (BITS . 15)) (
ETHERPACKET 310 (BITS . 15)) (ETHERPACKET 311 (BITS . 15)) (ETHERPACKET 312 (
BITS . 15)) (ETHERPACKET 313 (BITS . 15)) (ETHERPACKET 314 (BITS . 15)) (
ETHERPACKET 315 (BITS . 15)) (ETHERPACKET 316 (BITS . 15)) (ETHERPACKET 317 (
BITS . 15)) (ETHERPACKET 318 (BITS . 15)) (ETHERPACKET 319 (BITS . 15)) (
ETHERPACKET 320 (BITS . 15)) (ETHERPACKET 321 (BITS . 15)) (ETHERPACKET 322 (
BITS . 15)))) (QUOTE 324))
(SETTOPVAL (QUOTE \FREE.PACKET.QUEUE) (NCREATE (QUOTE SYSQUEUE)))
(/DECLAREDATATYPE (QUOTE NSADDRESS) (QUOTE (FIXP WORD WORD WORD WORD)) (QUOTE
 ((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) (
NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15)))) (QUOTE 6))
(CL:PROCLAIM (QUOTE (CL:SPECIAL *NSADDRESS-FORMAT*)))
(DEFPRINT (QUOTE NSADDRESS) (QUOTE \NSADDRESS.DEFPRINT))
(\ETHERINIT)
(MOVD? (QUOTE NILL) (QUOTE BLOCK))
(MOVD? (QUOTE NILL) (QUOTE \STASH.PASSWORDS))
(/DECLAREDATATYPE (QUOTE NDB) (QUOTE (BYTE POINTER BYTE POINTER BYTE POINTER 
BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER WORD WORD POINTER)) (QUOTE ((NDB 0 (BITS . 7)
) (NDB 2 POINTER) (NDB 1 (BITS . 7)) (NDB 4 POINTER) (NDB 1 (BITS . 135)) (
NDB 6 POINTER) (NDB 0 (BITS . 135)) (NDB 8 POINTER) (NDB 10 (BITS . 7)) (NDB 
12 POINTER) (NDB 14 POINTER) (NDB 11 (BITS . 7)) (NDB 16 POINTER) (NDB 18 
POINTER) (NDB 20 POINTER) (NDB 22 POINTER) (NDB 24 POINTER) (NDB 26 POINTER) 
(NDB 28 POINTER) (NDB 30 POINTER) (NDB 32 (BITS . 15)) (NDB 33 (BITS . 15)) (
NDB 34 POINTER))) (QUOTE 36))
(SETTOPVAL (QUOTE \ROUTING.TABLE.TYPENUM) (\TYPENUMBERFROMNAME (PACK* 
"\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK))))
(SETTOPVAL (QUOTE \CENTICLOCKBOX) (NCREATE (QUOTE FIXP)))
|{DSK}<tilde>sybalsky>lispcore>sources>PUP.LCOM;2|
(SETTOPVAL (QUOTE \ETHERPORTS) (HASHARRAY 24Q))
(PUTPROP (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE
 optimize-GETPUPWORD) (GET (QUOTE GETPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST)
)))
(PUTPROP (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE
 optimize-PUTPUPWORD) (GET (QUOTE PUTPUPWORD) (QUOTE COMPILER:OPTIMIZER-LIST)
)))
(PUTPROP (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE
 optimize-GETPUPBYTE) (GET (QUOTE GETPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST)
)))
(PUTPROP (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE
 optimize-PUTPUPBYTE) (GET (QUOTE PUTPUPBYTE) (QUOTE COMPILER:OPTIMIZER-LIST)
)))
(MOVD? (QUOTE NILL) (QUOTE \CANONICALIZE.IP.HOSTNAME) NIL T)
(SETTOPVAL (QUOTE \PUP.ROUTING.TABLE) (CONS))
(SETTOPVAL (QUOTE \PUP.READY.EVENT) (CREATE.EVENT "Pup Ready"))
(SETTOPVAL (QUOTE \PUP.READY.LOCK) (CREATE.MONITORLOCK "Pup Ready"))
(/DECLAREDATATYPE (QUOTE PUPSOCKET) (QUOTE ((BITS 4) POINTER FIXP POINTER 
WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER)) (QUOTE ((PUPSOCKET 0 
(BITS . 3)) (PUPSOCKET 0 POINTER) (PUPSOCKET 2 FIXP) (PUPSOCKET 4 POINTER) (
PUPSOCKET 6 (BITS . 17Q)) (PUPSOCKET 7 (BITS . 17Q)) (PUPSOCKET 10Q (BITS . 
17Q)) (PUPSOCKET 11Q (BITS . 17Q)) (PUPSOCKET 4 (BITS . 3)) (PUPSOCKET 12Q 
POINTER) (PUPSOCKET 12Q (BITS . 3)) (PUPSOCKET 14Q POINTER))) (QUOTE 16Q))
(\PUPINIT)
|{DSK}<tilde>sybalsky>lispcore>sources>LEAF.LCOM;2|
(/DECLAREDATATYPE (QUOTE SEQUIN) (QUOTE (POINTER POINTER POINTER BYTE BYTE 
BYTE BYTE WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD 
POINTER POINTER POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER POINTER WORD WORD WORD FLAG POINTER POINTER 
POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((SEQUIN 0 POINTER) (SEQUIN 
2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 135)) (
SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 135)) (SEQUIN 8 (BITS . 15)) (SEQUIN 9
 (BITS . 15)) (SEQUIN 10 (BITS . 15)) (SEQUIN 11 (BITS . 15)) (SEQUIN 12 (
BITS . 15)) (SEQUIN 13 (BITS . 15)) (SEQUIN 14 (BITS . 15)) (SEQUIN 15 (BITS
 . 15)) (SEQUIN 16 (BITS . 15)) (SEQUIN 17 (BITS . 15)) (SEQUIN 18 (BITS . 15
)) (SEQUIN 19 (BITS . 15)) (SEQUIN 20 (BITS . 15)) (SEQUIN 22 POINTER) (
SEQUIN 24 POINTER) (SEQUIN 26 POINTER) (SEQUIN 26 (FLAGBITS . 0)) (SEQUIN 26 
(FLAGBITS . 16)) (SEQUIN 26 (FLAGBITS . 32)) (SEQUIN 26 (FLAGBITS . 48)) (
SEQUIN 28 POINTER) (SEQUIN 30 POINTER) (SEQUIN 32 POINTER) (SEQUIN 34 POINTER
) (SEQUIN 36 POINTER) (SEQUIN 38 POINTER) (SEQUIN 40 POINTER) (SEQUIN 42 
POINTER) (SEQUIN 44 POINTER) (SEQUIN 46 POINTER) (SEQUIN 48 POINTER) (SEQUIN 
50 POINTER) (SEQUIN 52 POINTER) (SEQUIN 54 POINTER) (SEQUIN 56 POINTER) (
SEQUIN 58 POINTER) (SEQUIN 60 POINTER) (SEQUIN 62 POINTER) (SEQUIN 21 (BITS
 . 15)) (SEQUIN 64 (BITS . 15)) (SEQUIN 65 (BITS . 15)) (SEQUIN 62 (FLAGBITS
 . 0)) (SEQUIN 66 POINTER) (SEQUIN 68 POINTER) (SEQUIN 70 POINTER) (SEQUIN 72
 POINTER) (SEQUIN 74 POINTER) (SEQUIN 76 POINTER) (SEQUIN 78 POINTER))) (
QUOTE 80))
(\LEAFINIT)
(/DECLAREDATATYPE (QUOTE PUPFILESERVER) (QUOTE (BYTE POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((
PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 
POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 8 POINTER) (PUPFILESERVER 
10 POINTER) (PUPFILESERVER 12 POINTER) (PUPFILESERVER 14 POINTER) (
PUPFILESERVER 16 POINTER) (PUPFILESERVER 18 POINTER) (PUPFILESERVER 20 
POINTER) (PUPFILESERVER 22 POINTER))) (QUOTE 24))
|{DSK}<tilde>sybalsky>lispcore>sources>PASSWORDS.LCOM;2|
(SETTOPVAL (QUOTE LOGINPASSWORDS) (HASHARRAY 8))
(SETTOPVAL (QUOTE \GETPASSWORD.LOCK) (CREATE.MONITORLOCK "GetPassword"))
(MOVD? (QUOTE NILL) (QUOTE CLBUFS))
|{DSK}<tilde>sybalsky>lispcore>sources>FONT.LCOM;5|
(MOVD (QUOTE FONTCLASSCOMPONENT) (QUOTE FONTCOMPONENT))
(MOVD (QUOTE SETFONTCLASSCOMPONENT) (QUOTE SETFONTCOMPONENT))
(/DECLAREDATATYPE (QUOTE FONTCLASS) (QUOTE (BYTE POINTER POINTER POINTER 
POINTER POINTER)) (QUOTE ((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) (
FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 
10 POINTER))) (QUOTE 12))
(/DECLAREDATATYPE (QUOTE FONTDESCRIPTOR) (QUOTE (POINTER POINTER POINTER 
POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD 
POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER
)) (QUOTE ((FONTDESCRIPTOR 0 POINTER) (FONTDESCRIPTOR 2 POINTER) (
FONTDESCRIPTOR 4 POINTER) (FONTDESCRIPTOR 6 POINTER) (FONTDESCRIPTOR 8 (BITS
 . 15)) (FONTDESCRIPTOR 9 (BITS . 15)) (FONTDESCRIPTOR 10 (BITS . 15)) (
FONTDESCRIPTOR 11 (BITS . 15)) (FONTDESCRIPTOR 12 (SIGNEDBITS . 15)) (
FONTDESCRIPTOR 13 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 14 (SIGNEDBITS . 15)) (
FONTDESCRIPTOR 15 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 16 POINTER) (
FONTDESCRIPTOR 18 POINTER) (FONTDESCRIPTOR 20 POINTER) (FONTDESCRIPTOR 22 
POINTER) (FONTDESCRIPTOR 24 POINTER) (FONTDESCRIPTOR 26 (BITS . 7)) (
FONTDESCRIPTOR 27 (BITS . 15)) (FONTDESCRIPTOR 28 POINTER) (FONTDESCRIPTOR 30
 POINTER) (FONTDESCRIPTOR 32 POINTER))) (QUOTE 34))
(/DECLAREDATATYPE (QUOTE CHARSETINFO) (QUOTE (POINTER POINTER POINTER POINTER
 POINTER WORD WORD POINTER)) (QUOTE ((CHARSETINFO 0 POINTER) (CHARSETINFO 2 
POINTER) (CHARSETINFO 4 POINTER) (CHARSETINFO 6 POINTER) (CHARSETINFO 8 
POINTER) (CHARSETINFO 10 (BITS . 15)) (CHARSETINFO 11 (BITS . 15)) (
CHARSETINFO 12 POINTER))) (QUOTE 14))
(\UNITWIDTHSVECTOR)
(CONSTANTS (NORUNCODE 255))
(PUTPROP (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
optimize-FONTPROP) (GET (QUOTE FONTPROP) (QUOTE COMPILER:OPTIMIZER-LIST))))
|{DSK}<tilde>sybalsky>lispcore>sunloadup>SUNFONT.LCOM;4|
(Value of DISPLAYFONTDIRECTORIES changed from ({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ |{dsk}/usr/local/lde/fonts/display/publishing/|) to ("{DSK}~/lispcore/fonts/display/presentation/" "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" "{DSK}~/lispcore/fonts/display/publishing/" "{DSK}~/lispcore/fonts/display/miscellaneous/"))
|{DSK}<tilde>sybalsky>lispcore>sources>LLDISPLAY.LCOM;2|
(/DECLAREDATATYPE (QUOTE BITMAP) (QUOTE (POINTER WORD WORD WORD WORD)) (QUOTE
 ((BITMAP 0 POINTER) (BITMAP 2 (BITS . 15)) (BITMAP 3 (BITS . 15)) (BITMAP 4 
(BITS . 15)) (BITMAP 5 (BITS . 15)))) (QUOTE 6))
(/DECLAREDATATYPE (QUOTE PILOTBBT) (QUOTE (WORD WORD WORD SIGNEDWORD WORD 
WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD)) (QUOTE ((
PILOTBBT 0 (BITS . 15)) (PILOTBBT 1 (BITS . 15)) (PILOTBBT 2 (BITS . 15)) (
PILOTBBT 3 (SIGNEDBITS . 15)) (PILOTBBT 4 (BITS . 15)) (PILOTBBT 5 (BITS . 15
)) (PILOTBBT 6 (BITS . 15)) (PILOTBBT 7 (SIGNEDBITS . 15)) (PILOTBBT 8 (BITS
 . 15)) (PILOTBBT 9 (BITS . 15)) (PILOTBBT 10 (BITS . 15)) (PILOTBBT 11 (BITS
 . 15)) (PILOTBBT 12 (BITS . 15)) (PILOTBBT 13 (BITS . 15)) (PILOTBBT 14 (
BITS . 15)) (PILOTBBT 15 (BITS . 15)))) (QUOTE 16))
(/DECLAREDATATYPE (QUOTE \DISPLAYDATA) (QUOTE (POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD FLAG 
XPOINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER 
POINTER POINTER POINTER WORD WORD POINTER WORD)) (QUOTE ((\DISPLAYDATA 0 
POINTER) (\DISPLAYDATA 2 POINTER) (\DISPLAYDATA 4 POINTER) (\DISPLAYDATA 6 
POINTER) (\DISPLAYDATA 8 POINTER) (\DISPLAYDATA 10 POINTER) (\DISPLAYDATA 12 
POINTER) (\DISPLAYDATA 14 POINTER) (\DISPLAYDATA 16 POINTER) (\DISPLAYDATA 18
 POINTER) (\DISPLAYDATA 20 POINTER) (\DISPLAYDATA 22 POINTER) (\DISPLAYDATA 
24 POINTER) (\DISPLAYDATA 26 POINTER) (\DISPLAYDATA 28 POINTER) (\DISPLAYDATA
 30 POINTER) (\DISPLAYDATA 32 POINTER) (\DISPLAYDATA 34 (BITS . 15)) (
\DISPLAYDATA 35 (BITS . 15)) (\DISPLAYDATA 36 (BITS . 15)) (\DISPLAYDATA 37 (
BITS . 15)) (\DISPLAYDATA 38 (BITS . 15)) (\DISPLAYDATA 32 (FLAGBITS . 0)) (
\DISPLAYDATA 40 XPOINTER) (\DISPLAYDATA 42 POINTER) (\DISPLAYDATA 44 POINTER)
 (\DISPLAYDATA 46 POINTER) (\DISPLAYDATA 48 POINTER) (\DISPLAYDATA 50 POINTER
) (\DISPLAYDATA 52 POINTER) (\DISPLAYDATA 54 POINTER) (\DISPLAYDATA 56 
POINTER) (\DISPLAYDATA 58 POINTER) (\DISPLAYDATA 60 POINTER) (\DISPLAYDATA 62
 POINTER) (\DISPLAYDATA 39 (BITS . 15)) (\DISPLAYDATA 64 (BITS . 15)) (
\DISPLAYDATA 66 POINTER) (\DISPLAYDATA 65 (BITS . 15)))) (QUOTE 68))
(PUTPROP (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE optimize-\FBITMAPBIT) (GET (QUOTE \FBITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST))))
(INITBITMASKS)
(SETTOPVAL (QUOTE CursorBitMap) (\CreateCursorBitMap))
(CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0))
(MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT))
(PUTPROP (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
optimize-BITMAPBIT) (GET (QUOTE BITMAPBIT) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
optimize-BITMAPP) (GET (QUOTE BITMAPP) (QUOTE COMPILER:OPTIMIZER-LIST))))
(MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT))
(MOVD? (QUOTE \ILLEGAL.ARG) (QUOTE \COERCETODS))
(MOVD? (QUOTE NILL) (QUOTE WFROMDS))
(MOVD? (QUOTE NILL) (QUOTE WINDOWP))
(MOVD? (QUOTE NILL) (QUOTE INVERTW))
(MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS))
(PUTPROP (QUOTE TTYDISPLAYSTREAM) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN 
(QUOTE optimize-TTYDISPLAYSTREAM) (GET (QUOTE TTYDISPLAYSTREAM) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(SETF-MACRO-FUNCTION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE 
expand-\MAYBE-DRIBBLE-CHAR))
(SET-DOCUMENTATION (QUOTE \MAYBE-DRIBBLE-CHAR) (QUOTE CL:FUNCTION) 
"if we are dribbling, then dribble this character")
(UPDATESCREENDIMENSIONS)
(Value of \MaxScreenPage changed from 0 to -1)
(SETTOPVAL (QUOTE ScreenBitMap) (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT
))
(CURSOR.INIT)
(INITIALIZEDISPLAYSTREAMS)
(DISPLAYSTREAMINIT 1000)
|{DSK}<tilde>sybalsky>lispcore>sources>APUTDQ.LCOM;2|
(DUMMYDEF (ADDSTATS *) (LISPXWATCH NILL) (CLBUFS NILL) (FINDFILE INFILEP) (
FILEMAP *) (VIRGINFN GETD))
(DUMMYDEF (* QUOTE) (GETP GETPROP) (DECLARE QUOTE) (FRPLNODE2 RPLNODE2) (
DISPLAYTERMP TRUE) (FRPLACA RPLACA) (FRPLACD RPLACD) (MISSPELLED? NILL) (
UNDOSAVE NILL) (SETLINELENGTH ZERO) (DOBE NILL) (RELINK NILL) (PUT PUTPROP) (
/PUT PUTPROP))
(SETTOPVAL (QUOTE SYSHASHARRAY) (HASHARRAY 50))
|{DSK}<tilde>sybalsky>lispcore>sources>COMPATIBILITY.LCOM;2|
(MOVD (QUOTE HARRAYP) (QUOTE HASHARRAYP))
|{DSK}<tilde>sybalsky>lispcore>sources>DMISC.LCOM;2|
(BACKSPACEDEL \ORIGTERMTABLE)
(BACKSPACEDEL NIL)
(SETTOPVAL (QUOTE \LASTRECLAIM) (\DAYTIME0 (NCREATE (QUOTE FIXP))))
(APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM)
(APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS))
(MOVD (QUOTE RINGBELLS) (QUOTE PRINTBELLS))
(OR (LISTP (EVALV (QUOTE EDITCHARACTERS))) (RPAQ EDITCHARACTERS (QUOTE (J X Z
 Y N))))
|{DSK}<tilde>sybalsky>lispcore>sources>CMLMACROS.LCOM;2|
(Property CMLMACROS of FILEDATES has been changed)
(APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO)
(Property * of MACRO has been changed)
(SETF-MACRO-FUNCTION (QUOTE CL:MACROLET) (QUOTE CL::expand-MACROLET))
(CL::SET-SETF-INVERSE (QUOTE CL:MACRO-FUNCTION) (QUOTE SETF-MACRO-FUNCTION))
(Property CMLMACROS of FILETYPE has been changed)
(Property CMLMACROS of COPYRIGHT has been changed)
|{DSK}<tilde>sybalsky>lispcore>sources>CMLLIST.LCOM;2|
(SET-SETF-INVERSE (QUOTE NTH) (QUOTE %SET-NTH))
(IL:PUTPROP (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-NTH|) (GET (QUOTE NTH) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:MOVD (QUOTE %SET-NTH) (QUOTE IL:%SETNTH))
(IL:PUTPROP (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-FIRST|) (GET (QUOTE FIRST) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-SECOND|) (GET (QUOTE SECOND) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-THIRD|) (GET (QUOTE THIRD) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-FOURTH|) (GET (QUOTE FOURTH) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-FIFTH|) (GET (QUOTE FIFTH) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-SIXTH|) (GET (QUOTE SIXTH) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-SEVENTH|) (GET (QUOTE SEVENTH) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-EIGHTH|) (GET (QUOTE EIGHTH) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-NINTH|) (GET (QUOTE NINTH) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-TENTH|) (GET (QUOTE TENTH) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-REST|) (GET (QUOTE REST) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-NTHCDR|) (GET (QUOTE NTHCDR) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-MEMBER|) (GET (QUOTE MEMBER) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-ADJOIN|) (GET (QUOTE ADJOIN) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|definline-ACONS|) (GET (QUOTE ACONS) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-ASSOC|) (GET (QUOTE ASSOC) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:SETF-MACRO-FUNCTION (QUOTE %LIST-COLLECT) (QUOTE |expand-%LIST-COLLECT|))
(IL:PUTPROP (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-MAPCAR|) (GET (QUOTE MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-MAPLIST|) (GET (QUOTE MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-MAPC|) (GET (QUOTE MAPC) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-MAPL|) (GET (QUOTE MAPL) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-MAPCAN|) (GET (QUOTE MAPCAN) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
|optimize-MAPCON|) (GET (QUOTE MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
IL:|optimize-MAP|) (GET (QUOTE IL:MAP) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
IL:|optimize-MAPC|) (GET (QUOTE IL:MAPC) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE
 IL:|optimize-MAPLIST|) (GET (QUOTE IL:MAPLIST) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
IL:|optimize-MAPCAR|) (GET (QUOTE IL:MAPCAR) (QUOTE COMPILER:OPTIMIZER-LIST))
))
(IL:PUTPROP (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
IL:|optimize-MAPCON|) (GET (QUOTE IL:MAPCON) (QUOTE COMPILER:OPTIMIZER-LIST))
))
(IL:PUTPROP (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE
 IL:|optimize-MAPCONC|) (GET (QUOTE IL:MAPCONC) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
IL:|optimize-SOME|) (GET (QUOTE IL:SOME) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
IL:|optimize-EVERY|) (GET (QUOTE IL:EVERY) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
IL:|optimize-NOTANY|) (GET (QUOTE IL:NOTANY) (QUOTE COMPILER:OPTIMIZER-LIST))
))
(IL:PUTPROP (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (
QUOTE IL:|optimize-NOTEVERY|) (GET (QUOTE IL:NOTEVERY) (QUOTE COMPILER:OPTIMIZER-LIST))))
(IL:PUTPROP (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST) (ADJOIN (QUOTE 
IL:|optimize-SUBSET|) (GET (QUOTE IL:SUBSET) (QUOTE COMPILER:OPTIMIZER-LIST))
))
(IL:SETF-MACRO-FUNCTION (QUOTE XCL:WITH-COLLECTION) (QUOTE 
XCL::|expand-WITH-COLLECTION|))
(IL:MOVD (QUOTE IL:FMEMB) (QUOTE IL:MEMQ))
|{DSK}<tilde>sybalsky>lispcore>sources>CMLCHARACTER.LCOM;5|
(PUTPROP (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
optimize-CHARCODE) (GET (QUOTE CHARCODE) (QUOTE COMPILER:OPTIMIZER-LIST))))
(XCL::SET-CONSTANTP (QUOTE \CHARHI) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT \CHARHI)))
(XCL::SET-CONSTANTP (QUOTE CL:CHAR-BITS-LIMIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-BITS-LIMIT)))
(XCL::SET-CONSTANTP (QUOTE CL:CHAR-CODE-LIMIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CODE-LIMIT)))
(XCL::SET-CONSTANTP (QUOTE CL:CHAR-CONTROL-BIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-CONTROL-BIT)))
(XCL::SET-CONSTANTP (QUOTE CL:CHAR-FONT-LIMIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-FONT-LIMIT)))
(XCL::SET-CONSTANTP (QUOTE CL:CHAR-HYPER-BIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-HYPER-BIT)))
(XCL::SET-CONSTANTP (QUOTE CL:CHAR-META-BIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-META-BIT)))
(XCL::SET-CONSTANTP (QUOTE CL:CHAR-SUPER-BIT) NIL)
(CL:PROCLAIM (QUOTE (SI::CONSTANT CL:CHAR-SUPER-BIT)))
(PUTPROP (QUOTE CL:CHAR-CODE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-CHAR-CODE) (GET (QUOTE CL:CHAR-CODE) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-CHAR-INT) (GET (QUOTE CL:CHAR-INT) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CODE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-CODE-CHAR) (GET (QUOTE CL:CODE-CHAR) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-INT-CHAR) (GET (QUOTE CL:INT-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST))))
(SETTOPVAL (\TYPEGLOBALVARIABLE (QUOTE CHARACTER) T) (NTYPX (CL:CODE-CHAR 0 0
 0)))
(DEFPRINT (QUOTE CHARACTER) (QUOTE CHARACTER.PRINT))
(PUTPROP (QUOTE CL:CHAR-UPCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-CHAR-UPCASE) (GET (QUOTE CL:CHAR-UPCASE) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR-DOWNCASE) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN 
(QUOTE CL::optimize-CHAR-DOWNCASE) (GET (QUOTE CL:CHAR-DOWNCASE) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:MAKE-CHAR) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-MAKE-CHAR) (GET (QUOTE CL:MAKE-CHAR) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(SET-DOCUMENTATION (QUOTE CL:DIGIT-CHAR-P) (QUOTE CL:FUNCTION) 
"Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix.")
(PUTPROP (QUOTE CL:CHAR-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-CHAR-EQUAL) (GET (QUOTE CL:CHAR-EQUAL) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN 
(QUOTE CL::optimize-CHAR-GREATERP) (GET (QUOTE CL:CHAR-GREATERP) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-CHAR-LESSP) (GET (QUOTE CL:CHAR-LESSP) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN
 (QUOTE CL::optimize-CHAR-NOT-EQUAL) (GET (QUOTE CL:CHAR-NOT-EQUAL) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST) (
CL:ADJOIN (QUOTE CL::optimize-CHAR-NOT-GREATERP) (GET (QUOTE 
CL:CHAR-NOT-GREATERP) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR-NOT-LESSP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN
 (QUOTE CL::optimize-CHAR-NOT-LESSP) (GET (QUOTE CL:CHAR-NOT-LESSP) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::optimize-CHAR/=) (GET (QUOTE CL:CHAR/=) (QUOTE COMPILER:OPTIMIZER-LIST)))
)
(PUTPROP (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::optimize-CHAR<) (GET (QUOTE CL:CHAR<) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::optimize-CHAR<=) (GET (QUOTE CL:CHAR<=) (QUOTE COMPILER:OPTIMIZER-LIST)))
)
(PUTPROP (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::optimize-CHAR=) (GET (QUOTE CL:CHAR=) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::optimize-CHAR>) (GET (QUOTE CL:CHAR>) (QUOTE COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE 
CL::optimize-CHAR>=) (GET (QUOTE CL:CHAR>=) (QUOTE COMPILER:OPTIMIZER-LIST)))
)
(PUTPROP (QUOTE CL:CHARACTERP) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-CHARACTERP) (GET (QUOTE CL:CHARACTERP) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:LOWER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-LOWER-CASE-P) (GET (QUOTE CL:LOWER-CASE-P) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:STRING-CHAR-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN 
(QUOTE CL::optimize-STRING-CHAR-P) (GET (QUOTE CL:STRING-CHAR-P) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(PUTPROP (QUOTE CL:UPPER-CASE-P) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (
QUOTE CL::optimize-UPPER-CASE-P) (GET (QUOTE CL:UPPER-CASE-P) (QUOTE 
COMPILER:OPTIMIZER-LIST))))
(SETF-MACRO-FUNCTION (QUOTE %%CHAR-DOWNCASE-CODE) (QUOTE 
expand-%%CHAR-DOWNCASE-CODE))
(SETF-MACRO-FUNCTION (QUOTE %%CHAR-UPCASE-CODE) (QUOTE 
expand-%%CHAR-UPCASE-CODE))
(SETF-MACRO-FUNCTION (QUOTE %%CODE-CHAR) (QUOTE expand-%%CODE-CHAR))
|{DSK}<tilde>sybalsky>lispcore>sources>CMLREADTABLE.LCOM;4|
(CL:PROCLAIM (QUOTE (CL:SPECIAL *READ-SUPPRESS*)))
(OR (BOUNDP (QUOTE *READ-SUPPRESS*)) (CL:SETQ *READ-SUPPRESS* NIL))
(INIT-CML-READTABLES)
|{DSK}<tilde>sybalsky>lispcore>sunloadup>MAIKOLOADUPFNS.LCOM;1|
|{DSK}<tilde>sybalsky>lispcore>sources>MAIKOBITBLT.LCOM;2|
(MOVD (QUOTE \\BITBLT.BITMAP) (QUOTE \\MAIKO.OLDBITBLT.BITMAP))
=|{DSK}<tilde>sybalsky>lispcore>sunloadup>MAIKOINIT.;1|
|{DSK}<tilde>sybalsky>lispcore>sunloadup>MAIKOINIT.;1|
(QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* 
XCL::*DELETED-IMPLICIT-HASH-SLOT*))
(Value of LOADUPDIRECTORIES changed from ({ERIS}<LISPCORE>SOURCES> {ERIS}<LISPCORE>LIBRARY> {ERIS}<LISPUSERS>) to ("{dsk}~/lispcore/4-BYTE-ATOMS/" "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/3-BYTE-ATOMS/" "{DSK}~/lispcore/sunloadup/"))


POSTINITARRAYS:  There were 36 allocated but unused array pages.

*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
***********************************************************************
[FPTOVP]*********************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
***********xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx******************
***********************[PageMaps]********************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
*****************************************************************************
************************
\ No newline at end of file
diff --git a/internal/makesysout/sunloadup/LispDlion.db b/internal/makesysout/sunloadup/LispDlion.db
new file mode 100644
index 00000000..caf1b2fc
Binary files /dev/null and b/internal/makesysout/sunloadup/LispDlion.db differ
diff --git a/internal/makesysout/sunloadup/LispDove.db b/internal/makesysout/sunloadup/LispDove.db
new file mode 100644
index 00000000..a2ca1ebd
Binary files /dev/null and b/internal/makesysout/sunloadup/LispDove.db differ
diff --git a/internal/makesysout/sunloadup/MAIKOINIT b/internal/makesysout/sunloadup/MAIKOINIT
new file mode 100644
index 00000000..a57ccc94
--- /dev/null
+++ b/internal/makesysout/sunloadup/MAIKOINIT
@@ -0,0 +1,7 @@
+
+(RPAQQ SI::*CLOSURE-CACHE-ENABLED* NIL)
+
+(QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT* ))
+
+(PUTPROPS MAIKOINIT COPYRIGHT ("Venue" 1990))
+STOP
diff --git a/internal/makesysout/sunloadup/MAIKOLOADUPFNS b/internal/makesysout/sunloadup/MAIKOLOADUPFNS
new file mode 100644
index 00000000..3a3e4a35
--- /dev/null
+++ b/internal/makesysout/sunloadup/MAIKOLOADUPFNS
@@ -0,0 +1,589 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+(FILECREATED " 5-Apr-89 16:23:30" {ERIS}<LISPCORE>SUNLOADUP>MAIKOLOADUPFNS.;6 32845  
+
+      changes to%:  (VARS MAIKOLOADUPFNSCOMS)
+                    (FNS \DISPLAYLINE \10MB.STARTDRIVER \PAGEFAULT \COUNTREALPAGES \MOVEVMEMFILEPAGE
+                         \LOADVMEMPAGE CHECKPAGEMAP \SHOWPAGETABLE \DIRTYBACKGROUND \WRITEDIRTYPAGE 
+                         \UNLOCKPAGES \TEMPUNLOCKPAGES \DOTEMPLOCKPAGES \DOLOCKPAGES \LOCKPAGES 
+                         \DONEWPAGE \NEWPAGE \LOCKEDPAGEP \DORECLAIM CL::%%COPY-TIME-STATS SETTIME 
+                         \PUP.SETTIME \NS.SETTIME CLOCK CLOCK0 \CLOCK0 \DAYTIME0 DAYTIME \CHECKSUM 
+                         \10MB.RESTART.ETHER \10MB.TURNONETHER \10MB.TURNOFFETHER \10MBSENDPACKET 
+                         \10MBWATCHER \BITBLTSUB \BLTCHAR FIE)
+                    (FILES LLNSDECLS)
+                    (PROPS (MAIKOLOADUPFNS MAKEFILE-ENVIRONMENT))
+
+      previous date%: " 5-Apr-89 14:47:33" {ERIS}<LISPCORE>SUNLOADUP>MAIKOLOADUPFNS.;1)
+
+
+(* "
+Copyright (c) 1989 by ENVOS Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT MAIKOLOADUPFNSCOMS)
+
+(RPAQQ MAIKOLOADUPFNSCOMS 
+       [(PROP (FILETYPE MAKEFILE-ENVIRONMENT)
+              MAIKOLOADUPFNS)
+        (FNS CL::%%COPY-TIME-STATS CHECKPAGEMAP CLOCK CLOCK0 DAYTIME SETTIME \10MB.RESTART.ETHER 
+             \10MB.STARTDRIVER \10MB.TURNOFFETHER \10MB.TURNONETHER \10MBSENDPACKET \10MBWATCHER 
+             \BITBLTSUB \BLTCHAR \CHECKSUM \CLOCK0 \COUNTREALPAGES \DAYTIME0 \DIRTYBACKGROUND 
+             \DISPLAYLINE \DOLOCKPAGES \DONEWPAGE \DORECLAIM \DOTEMPLOCKPAGES \LOADVMEMPAGE 
+             \LOCKEDPAGEP \LOCKPAGES \MOVEVMEMFILEPAGE \NEWPAGE \NS.SETTIME \PAGEFAULT \PUP.SETTIME 
+             \SHOWPAGETABLE \TEMPUNLOCKPAGES \UNLOCKPAGES \WRITEDIRTYPAGE)
+        (GLOBALVARS \TimeZoneComp \10MB.RCLK.BOX \10MB.EXPECTED.RECEIVE.INTERVAL \10MB.INPUT.TIMEOUT
+               \10MB.INPUT.TIMER \10MBTYPE.TRANSLATIONS \MY.NSADDRESS \RAWTRACING \MAXWATCHERGETS)
+        (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T)
+               (FILES (SOURCE)
+                      10MBDECLS LLNSDECLS TEDITDECLS))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA \WRITEDIRTYPAGE \UNLOCKPAGES \TEMPUNLOCKPAGES \SHOWPAGETABLE 
+                            \MOVEVMEMFILEPAGE \LOCKPAGES \LOCKEDPAGEP \DOTEMPLOCKPAGES \DOLOCKPAGES 
+                            \DIRTYBACKGROUND \COUNTREALPAGES CHECKPAGEMAP])
+
+(PUTPROPS MAIKOLOADUPFNS FILETYPE CL:COMPILE-FILE)
+
+(PUTPROPS MAIKOLOADUPFNS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE
+                                                         10))
+(DEFINEQ
+
+(CL::%%COPY-TIME-STATS
+  [LAMBDA (REFERENCE-BLOCK DESTINIATION-BLOCK)        (* ; "Edited  2-May-88 17:16 by MASINTER")
+    (SUBRCALL COPYTIMESTATS REFERENCE-BLOCK DESTINIATION-BLOCK])
+
+(CHECKPAGEMAP
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    NIL])
+
+(CLOCK
+  [LAMBDA (N BOX)                                     (* ; "Edited  2-May-88 16:11 by MASINTER")
+    (SUBRCALL GETUNIXTIME N BOX])
+
+(CLOCK0
+  [LAMBDA (BOX)                                       (* ; "Edited  2-May-88 16:19 by MASINTER")
+    (SUBRCALL GETUNIXTIME 0 BOX])
+
+(DAYTIME
+  [LAMBDA (BOX)                                       (* ; "Edited  2-May-88 16:20 by MASINTER")
+    (SUBRCALL GETUNIXTIME 5 BOX])
+
+(SETTIME
+  [LAMBDA (RETFLG)                                    (* ; "Edited 13-May-88 15:22 by MASINTER")
+    (CL:UNLESS (AND RETFLG (NOT (STRINGP RETFLG)))
+        (SETQ \TimeZoneComp (SUBRCALL GETUNIXTIME 8 NIL)))
+    (\PROCESS.RESET.TIMERS)
+    (DAYTIME])
+
+(\10MB.RESTART.ETHER
+  [LAMBDA NIL                                         (* ; "Edited 11-May-88 16:09 by MASINTER")
+    (SUBRCALL ETHER-RESUME])
+
+(\10MB.STARTDRIVER
+  [LAMBDA (NDB RESTARTFLG MYNSNUMBER)                    (* ; "Edited  5-Apr-89 15:03 by snow")
+    (DECLARE (GLOBALVARS \MAIKO.INPUT.PACKET \10MB.EXPECTED.RECEIVE.INTERVAL \10MB.INPUT.TIMEOUT)
+           )
+    (SUBRCALL ETHER-SUSPEND)
+    (OR (\INIT.ETHER.BUFFER.POOL)
+        (ERROR "Unable to create buffer pool"))
+    (replace NDBTQ of NDB with (create SYSQUEUE))
+    (SETQ \10MB.RAWPACKETQ (create SYSQUEUE))
+    (SETQ \10MB.INPUT.TIMEOUT (TIMES \RCLKSECOND \10MB.EXPECTED.RECEIVE.INTERVAL))
+    (\10MB.TURNONETHER NDB NIL NIL (OR MYNSNUMBER T)
+           0 0)
+    (PROG ((CSB (fetch NDBCSB of NDB)))
+          (OR \MAIKO.INPUT.PACKET (SETQ \MAIKO.INPUT.PACKET (\ALLOCATE.ETHERPACKET)))
+          (replace DLFIRSTICB of (fetch NDBCSB of NDB) with \ES.PENDING)
+          (SUBRCALL ETHER-GET \10MBPACKETLENGTH (fetch 10MBPACKETBASE of \MAIKO.INPUT.PACKET)
+                 )
+          (replace NDBWATCHER of NDB with (ADD.PROCESS (LIST '\10MBWATCHER (KWOTE NDB))
+                                                             'RESTARTABLE
+                                                             'SYSTEM
+                                                             'AFTEREXIT
+                                                             'DELETE))
+          (RETURN NDB])
+
+(\10MB.TURNOFFETHER
+  [LAMBDA NIL                                         (* ; "Edited 11-May-88 16:11 by MASINTER")
+    (SUBRCALL ETHER-SUSPEND])
+
+(\10MB.TURNONETHER
+  [LAMBDA (NDB SMASHSTATE NEWSTATE NSHOSTNUMBER ININTERRUPT OUTINTERRUPT)
+                                                          (* ; "Edited 11-May-88 16:08 by MASINTER")
+
+(* ;;; "Reset and activate ether associated with NDB.  If SMASHSTATE is given, it is a CSB-length block into which state is saved for later restoration by passing as the NEWSTATE arg.  If NEWSTATE is NIL, then the remaining non-NIL args give parameters for this activation: the host number for microcode to watch for, T meaning my own number;  and interrupt masks for when a packet arrives or finishes transmitting")
+
+    (* ;; "For Daybreak, SMASHSTATE and NEWSTATE must be NIL")
+
+    (PROG ((CSB (fetch NDBCSB of NDB)))
+          (\MAIKO.ETHERSUSPEND)
+          [OR CSB (replace NDBCSB of NDB with (SETQ CSB (LOCF (fetch DLETHERNET
+                                                                             of \IOPAGE]
+          (replace DLFIRSTOCB of CSB with 0)
+          (replace DLFIRSTICB of CSB with 0)
+          [AND NSHOSTNUMBER (COND
+                               ((EQ NSHOSTNUMBER T)
+                                (\BLT (LOCF (fetch DLLOCALHOST0 of CSB))
+                                      (LOCF (fetch (IFPAGE NSHost0) of \InterfacePage))
+                                      \#WDS.NSHOSTNUMBER))
+                               (T (\STORENSHOSTNUMBER (LOCF (fetch DLLOCALHOST0 of CSB))
+                                         NSHOSTNUMBER]
+          (AND OUTINTERRUPT (replace DLOUTPUTMASK of CSB with OUTINTERRUPT))
+          (AND ININTERRUPT (replace DLINPUTMASK of CSB with ININTERRUPT))
+          (replace DLMISSEDPACKETS of CSB with 0)
+          (replace DLLASTICB of CSB with 0)
+          (replace DLLASTOCB of CSB with 0)
+          (SUBRCALL ETHER-RESET)
+          (SUBRCALL ETHER-RESUME)
+          (RETURN NDB])
+
+(\10MBSENDPACKET
+  [LAMBDA (NDB PACKET)                                (* ; "Edited 11-May-88 16:10 by MASINTER")
+    (PROG NIL
+          [COND
+             (\RAWTRACING (\MAYBEPRINTPACKET PACKET 'RAWPUT]
+          [COND
+             ((OR (fetch 10MBMULTICASTP of PACKET)
+                  (EQNSADDRESS.HOST \MY.NSADDRESS (fetch 10MBDESTHOSTBASE of PACKET)))
+                                                             (* ; 
+                                "We would hear this packet if our hardware let us, so fake receipt")
+              (PROG ((COPYPACKET (\ALLOCATE.ETHERPACKET)))
+                    (\BLT (LOCF (fetch 10MBLENGTH of COPYPACKET))
+                          (LOCF (fetch 10MBLENGTH of PACKET))
+                          (ADD1 (fetch 10MBLENGTH of PACKET)))
+                                                             (* ; 
+                                                   "Copy all data that would have been transmitted")
+                    (replace EPNETWORK of COPYPACKET with NDB)
+                    (replace EPTYPE of COPYPACKET
+                       with (for PAIR in \10MBTYPE.TRANSLATIONS
+                                   bind (TYPE _ (fetch 10MBTYPE of PACKET))
+                                   when (EQ TYPE (CAR PAIR)) do 
+
+                                 (* ;; "TYPE is the raw type of the etherpacket.  These do not always correspond one-to-one with the EPTYPE constants we use (in particular, for pups), so translate if necessary.")
+
+                                                                       (RETURN (CDR PAIR))
+                                   finally (RETURN TYPE)))
+                    [COND
+                       (\RAWTRACING (\MAYBEPRINTPACKET COPYPACKET 'RAWGET]
+                    (\HANDLE.RAW.PACKET COPYPACKET]
+          (UNINTERRUPTABLY
+              (SUBRCALL ETHER-SEND (IMAX (fetch 10MBLENGTH of PACKET)
+                                         \10MB.MINPACKETLENGTH)
+                     (fetch 10MBPACKETBASE of PACKET))
+              (replace EPNETWORK of PACKET with NIL)
+              (\REQUEUE.ETHERPACKET PACKET))
+          (RETURN T])
+
+(\10MBWATCHER
+  [LAMBDA (NDB)                                       (* ; "Edited 16-May-88 22:24 by MASINTER")
+
+    (* ;; "merge message and packet reading")
+
+    (PROG ((CNTR 0)
+           MESSAGE-BUFFER MESSAGE-LENGTH PACKET)
+      LP  (IF (SUBRCALL MESSAGE-READP)
+              THEN (PROMPTPRINT (IF (SETQ MESSAGE-LENGTH (SUBRCALL MESSAGE-READ
+                                                                        (OR MESSAGE-BUFFER
+                                                                            (SETQ MESSAGE-BUFFER
+                                                                             (ALLOCSTRING 1024)))
+                                                                        1024))
+                                        THEN (SUBSTRING MESSAGE-BUFFER 1 MESSAGE-LENGTH)
+                                      ELSE "?? system message: polling failed")))
+          (UNINTERRUPTABLY
+              (SUBRCALL ETHER-CHECK)
+              (SETQ PACKET (\MAIKO.INPUT.INTERRUPT NDB)))
+          [COND
+             (PACKET (\HANDLE.RAW.PACKET PACKET)
+                    (COND
+                       ((ILESSP (add CNTR 1)
+                               \MAXWATCHERGETS)
+                        (GO LP]
+          (BLOCK)
+          (SETQ CNTR 0)
+          (GO LP])
+
+(\BITBLTSUB
+  [LAMBDA (PILOTBBT SourceBitMap SLX STY DestinationBitMap DLX DTY HEIGHT SourceType Operation 
+                 Texture WindowXOffset WindowYOffset)    (* ; "Edited 29-Jun-88 16:24 by ")
+
+    (* ;; "replaces \BITBLTSUB on Maiko")
+
+    ((OPCODES SUBRCALL 69 13)
+     PILOTBBT SourceBitMap SLX STY DestinationBitMap DLX DTY HEIGHT SourceType Operation Texture 
+     WindowXOffset WindowYOffset])
+
+(\BLTCHAR
+  [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA)
+    ((OPCODES SUBRCALL 135 3)
+     CHARCODE DISPLAYSTREAM DISPLAYDATA])
+
+(\CHECKSUM
+  [LAMBDA (BASE NWORDS INITSUM)                       (* ; "Edited 20-May-88 11:48 by MASINTER")
+    (SUBRCALL CHECK-SUM BASE NWORDS INITSUM])
+
+(\CLOCK0
+  [LAMBDA (BOX)                                       (* ; "Edited  2-May-88 16:19 by MASINTER")
+    (SUBRCALL GETUNIXTIME 0 BOX])
+
+(\COUNTREALPAGES
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    0])
+
+(\DAYTIME0
+  [LAMBDA (BOX)                                       (* ; "Edited  2-May-88 16:20 by MASINTER")
+    (SUBRCALL GETUNIXTIME 4 BOX])
+
+(\DIRTYBACKGROUND
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    NIL])
+
+(\DISPLAYLINE
+  [LAMBDA (TEXTOBJ LINE WINDOW)                          (* ; "Edited  5-Apr-89 16:22 by snow")
+
+    (* ;; "Display the line of text LINE in the edit window where it belongs.")
+
+    (* ;; " This Function works on MIAKO")
+
+    (PROG ((CH 0)
+           (CHLIST (fetch (THISLINE CHARS) of (fetch THISLINE of TEXTOBJ)))
+           (WLIST (fetch (THISLINE WIDTHS) of (ffetch THISLINE of TEXTOBJ)))
+           (LOOKS (fetch (THISLINE LOOKS) of (ffetch THISLINE of TEXTOBJ)))
+           (WINDOWDS (WINDOWPROP (OR WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ)))
+                            'DSP))
+           (TEXTLEN (ffetch (TEXTOBJ TEXTLEN) of TEXTOBJ))
+           (THISLINE (ffetch (TEXTOBJ THISLINE) of TEXTOBJ))
+           (TERMSA (ffetch (TEXTOBJ TXTTERMSA) of TEXTOBJ))
+           (STREAM (ffetch (TEXTOBJ STREAMHINT) of TEXTOBJ))
+           (OLDCACHE (fetch LCBITMAP of (ffetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ)))
+           (DS (ffetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ))
+           (HCPYDS (ffetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ))
+           (HARDCOPYMODE (fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR LFMTSPEC)
+                                                                    of LINE)))
+           LOOKSTARTX CACHE \PCHARSLEFT \PSTRING \PFILE FONT OFONT OLOOKS XOFFSET CLIPLEFT CLIPRIGHT
+           DISPLAYDATA DDPILOTBBT DDWIDTHCACHE DDOFFSETCACHE CURY LHEIGHT SCALE)
+          [SETQ LHEIGHT (COND
+                           ((ffetch (LINEDESCRIPTOR PREVLINE) of LINE)
+                                                             (* ; 
+                                  "So if theres a base-to-base measure, we clear everything right.")
+                            (IMAX (IDIFFERENCE (fetch YBOT of (ffetch (LINEDESCRIPTOR
+                                                                                   PREVLINE)
+                                                                         of LINE))
+                                         (ffetch (LINEDESCRIPTOR YBOT) of LINE))
+                                  (ffetch (LINEDESCRIPTOR LHEIGHT) of LINE)))
+                           (T (ffetch (LINEDESCRIPTOR LHEIGHT) of LINE]
+          (COND
+             (HARDCOPYMODE                                   (* ; 
+                                                     "This is a hardcopy-mode line.  Scale things.")
+                                                             (* ; "(SETQ DS HCPYDS)")
+                    (SETQ SCALE (DSPSCALE NIL HCPYDS)))
+             (T (SETQ SCALE 1)))
+          (SETQ CACHE (\TEDIT.LINECACHE (ffetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ)
+                             (COND
+                                (HARDCOPYMODE (FIXR (FQUOTIENT (fetch RIGHTMARGIN of LINE)
+                                                           SCALE)))
+                                (T (fetch RIGHTMARGIN of LINE)))
+                             LHEIGHT))
+          (COND
+             ((NEQ CACHE OLDCACHE)                           (* ; 
+               "We changed the bitmaps because this line was bigger--update the displaystream, too")
+              (DSPDESTINATION CACHE DS)
+              (DSPCLIPPINGREGION (create REGION
+                                        LEFT _ 0
+                                        BOTTOM _ 0
+                                        WIDTH _ (fetch BITMAPWIDTH of CACHE)
+                                        HEIGHT _ (ffetch BITMAPHEIGHT of CACHE))
+                     DS)))
+          (BITBLT NIL 0 0 CACHE 0 0 NIL NIL 'TEXTURE 'REPLACE WHITESHADE)
+                                                             (* ; "Clear the line cache")
+          (COND
+             (HARDCOPYMODE                                   (* ; 
+                                                     "This is a hardcopy-mode line.  Scale things.")
+                                                             (* ; "(SETQ DS HCPYDS)")
+                    (SETQ SCALE (DSPSCALE NIL HCPYDS)))
+             (T (SETQ SCALE 1)))
+          [COND
+             ((AND (NOT (ZEROP (fetch CHAR1 of LINE)))
+                   (ILEQ (ffetch CHAR1 of LINE)
+                         TEXTLEN)
+                   (IGEQ (ffetch YBOT of LINE)
+                         (ffetch WBOTTOM of TEXTOBJ)))
+
+              (* ;; "Only display the line of it contains text (CHAR1 > 0), appears before the end of the test, and is on-screen.")
+
+              (COND
+                 ((NEQ (fetch DESC of THISLINE)
+                       LINE)                                 (* ; 
+                                                          "No image cache -- re-format and display")
+                  (\FORMATLINE TEXTOBJ NIL (ffetch CHAR1 of LINE)
+                         LINE)))
+              (MOVETO (ffetch LEFTMARGIN of LINE)
+                     (ffetch DESCENT of LINE)
+                     DS)
+              (SETQ DISPLAYDATA (fetch IMAGEDATA of DS))
+              (SETQ DDPILOTBBT (ffetch DDPILOTBBT of DISPLAYDATA))
+              (SETQ XOFFSET (ffetch DDXOFFSET of DISPLAYDATA))
+
+              (* ;; "The X position of the left edge of the window, since \TEDIT.BLTCHAR works on the screen bitmap itself.")
+
+              (SETQ CLIPLEFT (ffetch DDClippingLeft of DISPLAYDATA))
+                                                             (* ; 
+                     "The left and right edges of the clipping region for the text display window.")
+              (SETQ CLIPRIGHT (ffetch DDClippingRight of DISPLAYDATA))
+              (SETQ OFONT (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS 0)))
+                                 DS))                        (* ; "The starting font")
+              (SETQ DDWIDTHCACHE (ffetch DDWIDTHSCACHE of DISPLAYDATA))
+                                                             (* ; 
+                                                           "Cache the character-image widths")
+              (SETQ DDOFFSETCACHE (ffetch DDOFFSETSCACHE of DISPLAYDATA))
+                                                             (* ; 
+                                                          "And the offset-into-strike-bitmap array")
+              (SETQ LOOKSTARTX (ffetch LEFTMARGIN of LINE))
+                                                             (* ; 
+                                                  "Starting X position for the current-looks text.")
+              (AND (fetch CLOFFSET of OLOOKS)
+                   (RELMOVETO 0 (FIXR (FTIMES SCALE (ffetch CLOFFSET of OLOOKS)))
+                          DS))                               (* ; 
+                                                      "Any sub- or superscripting at start of line")
+              (bind (LOOKNO _ 1)
+                     DX
+                     (TX _ (IPLUS XOFFSET (ffetch LEFTMARGIN of LINE))) for I
+                 from 0 to (fetch LEN of THISLINE)
+                 do 
+
+                       (* ;; "Display the line character by character")
+
+                       (SETQ CH (\EDITELT CHLIST I))         (* ; 
+                                                      "Grab the character (or IMAGEOBJ) to display")
+                       (SETQ DX (\WORDELT WLIST I))          (* ; "And its width")
+                       [SELECTC CH
+                           (LMInvisibleRun                   (* ; 
+                                        "An INVISIBLE run -- skip it, and skip over the char count")
+                                (add LOOKNO 1))
+                           (LMLooksChange                    (* ; "A LOOKS change")
+                                          (freplace DDXPOSITION of DISPLAYDATA
+                                             with (IDIFFERENCE TX XOFFSET))
+                                                             (* ; 
+                                            "Make the displaystream reflect our current X position")
+                                          (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS
+                                                 (ffetch DESCENT of LINE))
+                                                             (* ; 
+                "Make any necessary changes to the preceding characters (underline, strike-out &c)")
+                                          (DSPFONT (fetch CLFONT of (SETQ OLOOKS
+                                                                             (\EDITELT LOOKS LOOKNO))
+                                                          )
+                                                 DS)         (* ; "Set the new font")
+                                          (add LOOKNO 1) (* ; "Grab the next set of char looks")
+                                          (AND (ffetch CLOFFSET of OLOOKS)
+                                               (RELMOVETO 0 (ffetch CLOFFSET of OLOOKS)
+                                                      DS))   (* ; "Account for super/subscripting")
+                                          (SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET))
+                                                             (* ; 
+                                     "Remember the starting Xpos for possible later underlining &c")
+                                          )
+                           ((CHARCODE (TAB %#^I))            (* ; 
+                                "TAB: use the width from the cache to decide the right formatting.")
+                                [COND
+                                   ((OR (IEQP CH (CHARCODE %#^I))
+                                        (ffetch CLLEADER of OLOOKS)
+                                        (EQ (ffetch CLUSERINFO of OLOOKS)
+                                            'DOTTEDLEADER))
+                                    (LET* [[LEADERFONT (COND
+                                                          (HARDCOPYMODE (FONTCOPY (ffetch CLFONT
+                                                                                     of OLOOKS)
+                                                                               'DEVICE HCPYDS))
+                                                          (T (ffetch CLFONT of OLOOKS]
+                                           (DOTWIDTH (CHARWIDTH (CHARCODE %.)
+                                                            LEADERFONT))
+                                           (TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH
+                                                                          (IREMAINDER TX DOTWIDTH]
+                                          (while (ILEQ TTX (IPLUS TX DX))
+                                             do (COND
+                                                       (HARDCOPYMODE
+                                                        (SUBRCALL TEDIT.BLTCHAR (CHARCODE %.)
+                                                               DS
+                                                               (FIXR (FQUOTIENT (IDIFFERENCE TTX 
+                                                                                       DOTWIDTH)
+                                                                            SCALE))
+                                                               DISPLAYDATA DDPILOTBBT CLIPRIGHT))
+                                                       ((OR TERMSA HARDCOPYMODE)
+                                                             (* ; 
+                                                           "Using special instrns from TERMSA")
+                                                        (\DSPPRINTCHAR DS (CHARCODE %.)))
+                                                       (T    (* ; "Native charcodes")
+                                                          (SUBRCALL TEDIT.BLTCHAR (CHARCODE %.)
+                                                                 DS
+                                                                 (IDIFFERENCE TTX DOTWIDTH)
+                                                                 DISPLAYDATA DDPILOTBBT CLIPRIGHT)))
+                                                   (add TTX DOTWIDTH])
+                           (13                               (* ; "It's a CR")
+                               NIL)
+                           (COND
+                              [(SMALLP CH)                   (* ; 
+                                                           "Normal character -- just display it.")
+                               (COND
+                                  (HARDCOPYMODE (SUBRCALL TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX 
+                                                                                           SCALE))
+                                                       DISPLAYDATA DDPILOTBBT CLIPRIGHT))
+                                  ((OR TERMSA HARDCOPYMODE)  (* ; 
+                                                           "Using special instrns from TERMSA")
+                                   (\DSPPRINTCHAR DS CH))
+                                  (T                         (* ; "Native charcodes")
+                                     (SUBRCALL TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT 
+                                            CLIPRIGHT]
+                              (T                             (* ; "CH is an object.")
+                                 (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
+                                                XOFFSET)
+                                        (SETQ CURY (DSPYPOSITION NIL DS))
+                                        DS)                  (* ; 
+                                              "Go to the base line, left edge of the image region.")
+                                 (APPLY* (IMAGEOBJPROP CH 'DISPLAYFN)
+                                        CH DS 'DISPLAY (ffetch STREAMHINT of TEXTOBJ))
+                                                             (* ; 
+                                                           "Tell him to display himself here.")
+                                 (DSPFONT (ffetch CLFONT of OLOOKS)
+                                        DS)
+                                 (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
+                                                XOFFSET)
+                                        CURY DS)             (* ; 
+                                                           "Move to after the object's image")
+                                 ]
+                       (add TX DX)                       (* ; "Update our X position")
+                 finally (freplace DDXPOSITION of DISPLAYDATA
+                                with (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE))
+                                                XOFFSET))    (* ; 
+                                      "Make any necessary looks mods to the last run of characters")
+                       (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (ffetch DESCENT of LINE]
+          (BITBLT CACHE 0 0 WINDOWDS 0 (ffetch YBOT of LINE)
+                 (ffetch WRIGHT of TEXTOBJ)
+                 LHEIGHT
+                 'INPUT
+                 'REPLACE)                                   (* ; 
+                        "Paint the cached image on the screen (this lessens flicker during update)")
+          (COND
+             ((fetch (FMTSPEC FMTREVISED) of (ffetch (LINEDESCRIPTOR LFMTSPEC)
+                                                        of LINE))
+                                                             (* ; 
+                                                     "This paragraph has been revised, so mark it.")
+              (\TEDIT.MARK.REVISION TEXTOBJ (ffetch (LINEDESCRIPTOR LFMTSPEC) of LINE)
+                     WINDOWDS LINE)))
+          (SELECTQ (ffetch LMARK of LINE)
+              (GREY                                          (* ; 
+              "This line has some property that isn't visible to the user.  Tell him to be careful")
+                    (BITBLT NIL 0 0 WINDOWDS 0 (ffetch YBASE of LINE)
+                           6 6 'TEXTURE 'PAINT 42405))
+              (SOLID                                         (* ; 
+              "This line has some property that isn't visible to the user.  Tell him to be careful")
+                     (BITBLT NIL 0 0 WINDOWDS 0 (ffetch YBASE of LINE)
+                            6 6 'TEXTURE 'PAINT BLACKSHADE))
+              (BITBLT NIL 0 0 WINDOWDS 0 (ffetch YBASE of LINE)
+                     6 6 'TEXTURE 'REPLACE WHITESHADE])
+
+(\DOLOCKPAGES
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    NIL])
+
+(\DONEWPAGE
+  [LAMBDA (BASE NOERROR LOCK?)                        (* ; "Edited 20-Apr-88 10:28 by MASINTER")
+    (SUBRCALL NEWPAGE BASE])
+
+(\DORECLAIM
+  [LAMBDA NIL                                         (* ; "Edited 12-Oct-88 12:01 by krivacic")
+    (SUBRCALL DORECLAIM])
+
+(\DOTEMPLOCKPAGES
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    NIL])
+
+(\LOADVMEMPAGE
+  [LAMBDA (X)                                                (* lmm%: 26 JUN 75 726)
+    X])
+
+(\LOCKEDPAGEP
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    T])
+
+(\LOCKPAGES
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    NIL])
+
+(\MOVEVMEMFILEPAGE
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    T])
+
+(\NEWPAGE
+  [LAMBDA (BASE NOERROR LOCK?)                        (* ; "Edited 20-Apr-88 10:28 by MASINTER")
+    (SUBRCALL NEWPAGE BASE])
+
+(\NS.SETTIME
+  [LAMBDA (RETFLG)                                    (* ; "Edited 13-May-88 15:22 by MASINTER")
+    (CL:UNLESS (AND RETFLG (NOT (STRINGP RETFLG)))
+        (SETQ \TimeZoneComp (SUBRCALL GETUNIXTIME 8 NIL)))
+    (\PROCESS.RESET.TIMERS)
+    (DAYTIME])
+
+(\PAGEFAULT
+  [LAMBDA (X)                                                (* lmm%: 26 JUN 75 726)
+    X])
+
+(\PUP.SETTIME
+  [LAMBDA (RETFLG)                                    (* ; "Edited 13-May-88 15:22 by MASINTER")
+    (CL:UNLESS (AND RETFLG (NOT (STRINGP RETFLG)))
+        (SETQ \TimeZoneComp (SUBRCALL GETUNIXTIME 8 NIL)))
+    (\PROCESS.RESET.TIMERS)
+    (DAYTIME])
+
+(\SHOWPAGETABLE
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    NIL])
+
+(\TEMPUNLOCKPAGES
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    NIL])
+
+(\UNLOCKPAGES
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    NIL])
+
+(\WRITEDIRTYPAGE
+  [LAMBDA NOBIND                                         (* lmm " 4-OCT-83 03:05")
+    NIL])
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \TimeZoneComp \10MB.RCLK.BOX \10MB.EXPECTED.RECEIVE.INTERVAL \10MB.INPUT.TIMEOUT 
+       \10MB.INPUT.TIMER \10MBTYPE.TRANSLATIONS \MY.NSADDRESS \RAWTRACING \MAXWATCHERGETS)
+)
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+
+
+(FILESLOAD (SOURCE)
+       10MBDECLS LLNSDECLS TEDITDECLS)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA )
+
+(ADDTOVAR NLAML )
+
+(ADDTOVAR LAMA \WRITEDIRTYPAGE \UNLOCKPAGES \TEMPUNLOCKPAGES \SHOWPAGETABLE \MOVEVMEMFILEPAGE 
+                         \LOCKPAGES \LOCKEDPAGEP \DOTEMPLOCKPAGES \DOLOCKPAGES \DIRTYBACKGROUND 
+                         \COUNTREALPAGES CHECKPAGEMAP)
+)
+(PUTPROPS MAIKOLOADUPFNS COPYRIGHT ("ENVOS Corporation" 1989))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (2805 32022 (CL::%%COPY-TIME-STATS 2815 . 3011) (CHECKPAGEMAP 3013 . 3131) (CLOCK 3133
+ . 3282) (CLOCK0 3284 . 3434) (DAYTIME 3436 . 3587) (SETTIME 3589 . 3863) (\10MB.RESTART.ETHER 3865 . 
+4023) (\10MB.STARTDRIVER 4025 . 5407) (\10MB.TURNOFFETHER 5409 . 5567) (\10MB.TURNONETHER 5569 . 7562)
+ (\10MBSENDPACKET 7564 . 9836) (\10MBWATCHER 9838 . 11159) (\BITBLTSUB 11161 . 11583) (\BLTCHAR 11585
+ . 11717) (\CHECKSUM 11719 . 11884) (\CLOCK0 11886 . 12037) (\COUNTREALPAGES 12039 . 12158) (\DAYTIME0
+ 12160 . 12313) (\DIRTYBACKGROUND 12315 . 12437) (\DISPLAYLINE 12439 . 29688) (\DOLOCKPAGES 29690 . 
+29808) (\DONEWPAGE 29810 . 29959) (\DORECLAIM 29961 . 30107) (\DOTEMPLOCKPAGES 30109 . 30231) (
+\LOADVMEMPAGE 30233 . 30348) (\LOCKEDPAGEP 30350 . 30466) (\LOCKPAGES 30468 . 30584) (
+\MOVEVMEMFILEPAGE 30586 . 30707) (\NEWPAGE 30709 . 30856) (\NS.SETTIME 30858 . 31136) (\PAGEFAULT 
+31138 . 31250) (\PUP.SETTIME 31252 . 31531) (\SHOWPAGETABLE 31533 . 31653) (\TEMPUNLOCKPAGES 31655 . 
+31777) (\UNLOCKPAGES 31779 . 31897) (\WRITEDIRTYPAGE 31899 . 32020)))))
+STOP
diff --git a/internal/makesysout/sunloadup/MAKE-UTILS b/internal/makesysout/sunloadup/MAKE-UTILS
new file mode 100644
index 00000000..de61be92
--- /dev/null
+++ b/internal/makesysout/sunloadup/MAKE-UTILS
@@ -0,0 +1,24 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(FILECREATED "12-Mar-92 15:41:46" |{DSK}<users>sybalsky>SUNLOADUP>MAKE-UTILS.;1| 906    
+
+      |changes| |to:|  (FNS DO-MAKE-COPIES))
+
+
+; Copyright (c) 1992 by Venue.  All rights reserved.
+
+(PRETTYCOMPRINT MAKE-UTILSCOMS)
+
+(RPAQQ MAKE-UTILSCOMS ((FNS DO-MAKE-COPIES)))
+(DEFINEQ
+
+(DO-MAKE-COPIES
+  (LAMBDA NIL                                            (* \; "Edited 12-Mar-92 15:40 by jds")
+    (COPYFILES "{PELE:MV:ENVOS}<LISPCORE>SOURCES>*.LCOM" "{DSK}~/3-BYTE-ATOMS/*.LCOM" '>A)
+    (COPYFILES "{PELE:MV:ENVOS}<LISPCORE>SOURCES>*.DFASL" "{DSK}~/3-BYTE-ATOMS/*.LCOM" '>A)
+    (COPYFILES "{PELE:MV:ENVOS}<LISPCORE>LIBRARY>*.LCOM" "{DSK}~/3-BYTE-LIB/*.LCOM" '>A)
+    (COPYFILES "{PELE:MV:ENVOS}<LISPCORE>LIBRARY>*.DFASL" "{DSK}~/3-BYTE-LIB/*.LCOM" '>A)))
+)
+(PUTPROPS MAKE-UTILS COPYRIGHT ("Venue" 1992))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (337 836 (DO-MAKE-COPIES 347 . 834)))))
+STOP
diff --git a/internal/makesysout/sunloadup/NLOCALFILE b/internal/makesysout/sunloadup/NLOCALFILE
new file mode 100644
index 00000000..078bcd41
--- /dev/null
+++ b/internal/makesysout/sunloadup/NLOCALFILE
@@ -0,0 +1,47 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+(filecreated "14-Aug-88 19:30:10" |{DSK}/usr/local/medley/sources/NLOCALFILE.;2| 2162   
+
+      |previous| |date:| "14-Aug-88 19:28:24" |{DSK}/usr/local/medley/sources/NLOCALFILE.;1|)
+
+
+(prettycomprint nlocalfilecoms)
+
+(rpaqq nlocalfilecoms ((records |GenerateFileState|)
+                           (fns |\\LFReturnNextFile| |\\LFReturnInfo|)))
+(declare\: eval@compile
+
+(typerecord |GenerateFileState| (currentfile restoffiles attributes))
+)
+(defineq
+
+(|\\LFReturnNextFile|
+  (lambda (generated)                                    (* |amd| "10-Feb-86 16:04")
+
+         (* * |comment|)
+
+    (|if| (null (|fetch| (|GenerateFileState| restoffiles) |of| generated))
+        |then| nil
+      |else| (|replace| (|GenerateFileState| currentfile) |of| generated
+                    |with| (|pop| (|fetch| (|GenerateFileState| restoffiles) |of|
+                                                                                         generated)))
+            (|fetch| (|GeneratedFile| fullname) |of| (|fetch| (|GenerateFileState| 
+                                                                                 currentfile)
+                                                                |of| generated)))))
+
+(|\\LFReturnInfo|
+  (lambda (generated prop)                               (* |amd| "10-Feb-86 16:04")
+
+         (* * |comment|)
+
+    (|for| attrib |in| (|fetch| (|GenerateFileState| attributes) |of| generated)
+       |as| infoval |in| (|fetch| (|GeneratedFile| info) |of| (|fetch|
+                                                                               (|GenerateFileState|
+                                                                                currentfile)
+                                                                                 |of| generated))
+       |do| (|if| (eq (mkatom (u-case attrib))
+                              (mkatom (u-case prop)))
+                    |then| (return infoval)))))
+)
+(declare\: dontcopy
+  (filemap (nil (513 2139 (|\\LFReturnNextFile| 523 . 1346) (|\\LFReturnInfo| 1348 . 2137)))))
+stop
diff --git a/internal/makesysout/sunloadup/POSTLOADUP b/internal/makesysout/sunloadup/POSTLOADUP
new file mode 100644
index 00000000..20beb166
--- /dev/null
+++ b/internal/makesysout/sunloadup/POSTLOADUP
@@ -0,0 +1,41 @@
+(FILECREATED " 8-DEC-81 15:27:54" <NEWMANUAL>POSTLOADUP.;2 982    
+
+     changes to:  POSTLOADUPCOMS
+
+     previous date: " 7-DEC-81 19:39:43" <NEWMANUAL>POSTLOADUP.;1)
+
+
+(*                                        Copyright (c) 1981
+                                                  by
+                                          Xerox Corporation                                         *)
+
+(PRETTYCOMPRINT POSTLOADUPCOMS)
+
+(RPAQQ POSTLOADUPCOMS [(* set up so that files can be loaded directly from phylum)
+		       (* turn off checking for dates of source)
+		       (P (MOVD (QUOTE NILL)
+				(QUOTE LOADUP2A))
+			  (CHANGENAME (QUOTE LOADUP2)
+				      (QUOTE ASSOC)
+				      (QUOTE TRUE])
+
+
+
+(* set up so that files can be loaded directly from phylum)
+
+
+
+
+(* turn off checking for dates of source)
+
+(MOVD (QUOTE NILL)
+      (QUOTE LOADUP2A))
+(CHANGENAME (QUOTE LOADUP2)
+	    (QUOTE ASSOC)
+	    (QUOTE TRUE))
+(DECLARE: DONTCOPY
+  (FILEMAP (NIL)))
+(PUTPROPS POSTLOADUP COPYRIGHTOWNER "Xerox Corporation")
+(PUTPROPS POSTLOADUP COPYRIGHTYEARS 1981)
+(PRINT (QUOTE (HI THERE)) T)
+STOP
diff --git a/internal/makesysout/sunloadup/REM.CM b/internal/makesysout/sunloadup/REM.CM
new file mode 100644
index 00000000..0121925e
--- /dev/null
+++ b/internal/makesysout/sunloadup/REM.CM
@@ -0,0 +1,7 @@
+"
+(PROGN (LOAD (QUOTE {dsk}SUNLOADUP/LOADUP.LISP))(SETQ IL:MAKESYSNAME :MEDLEY)(HARDRESET))
+SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'LISP.SYSOUT))
+SHH(PROGN (IL:LOAD '{dsk}SUNLOADUP/LOADFULL.LISP) (IL:MAKESYS 'FULL.SYSOUT) (IL:LOGOUT T))
+
+"
+
diff --git a/internal/makesysout/sunloadup/XREM-NOETHER.CM b/internal/makesysout/sunloadup/XREM-NOETHER.CM
new file mode 100644
index 00000000..19245020
--- /dev/null
+++ b/internal/makesysout/sunloadup/XREM-NOETHER.CM
@@ -0,0 +1,8 @@
+"
+(SETQ SI::*CLOSURE-CACHE-ENABLED* NIL)
+(QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT* ))
+(MOVD? (QUOTE NILL) (QUOTE PROMPTPRINT))
+(MOVD? (QUOTE NILL) (QUOTE CURSORP))
+(MOVD? (QUOTE NILL) (QUOTE CHANGEBACKGROUNDBORDER))
+(LOGOUT)
+"
diff --git a/internal/makesysout/sunloadup/bigFASTINIT.DFASL b/internal/makesysout/sunloadup/bigFASTINIT.DFASL
new file mode 100644
index 00000000..58354fec
Binary files /dev/null and b/internal/makesysout/sunloadup/bigFASTINIT.DFASL differ
diff --git a/internal/makesysout/sunloadup/runloadbig b/internal/makesysout/sunloadup/runloadbig
new file mode 100644
index 00000000..4a4ef4d5
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadbig
@@ -0,0 +1,113 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure thru to FULL.SYSOUT
+#
+#	Bootstrapping from 32-MB sysout version to 64- or
+#	larger sysouts.
+#
+######################################################################
+#
+#
+#  Things to watch for:
+#
+#	* LOADUP.LISP sets XCLC::*HOST-ARCHITECTURE*, which must match
+#	  what we want it to be in the new sysout.
+#
+#	* RDSYS needs to get re-built whenevver LLPARAMS is changed,
+#	  so the addresses of things like MDS Type Table track.
+#
+#	* SUNFONT contains directory names for font directories,
+#	  and may need to be updated if you move this directory.
+#
+#	* I had to define a function BIG-VMEM-CODE ( ( a b ) a), 
+#	  in order to compile LLKEY when making a fix...
+#
+#	* PARC's version of FONT has *USEOLDDIRECTORIES* = NIL,
+#	  which works WRONG with our font-directory layout.
+#
+#########################################################################
+#
+#	VARIABLES IN THIS FILE AND WHAT THEY MEAN...
+#
+#	LDE	The lde to be run in first phase.
+#	MAIKO	Directory the lde is in.
+#	INITLDE	path to ldeinit for step 2
+#
+#######################################################################
+
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set MAIKO = ~/maiko-9912/sunos5.sparc
+set LOADDIR = ~/lispcore
+set LDE			= $MAIKO/ldex-3.5
+set LDE2			= $MAIKO/ldex-3.51
+set LDEPATH = $MAIKO
+set INITLDE = $MAIKO/ldeinit
+#set INITLDEPATH		= $HOME/maiko/init.sgi
+set INITLDEPATH = ~/maiko-9912/init.sparc
+#set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+#set FULL_SYSOUT = $HOME/FULL.SYSOUT # FULL.SYSOUT
+set FULL_SYSOUT = /project/medley3.5/basics/full.sysout
+set FIRST_REM_CM	= $LOADDIR/sunloadup/XREM.CM
+set SECOND_REM_CM	= $LOADDIR/sunloadup/LOADFULL-REM.CM
+#set SECOND_REM_CM = $HOME/sunloadup/LOADBIGFULLFROMLISP-REM.CM
+#
+
+#########################################################
+#				   			#
+#	   S T E P   1		   			#
+#				   			#
+#  Using an existing sysout and emulator,		#
+#  create the new INIT.SYSOUT and INIT.DLINIT.		#
+#							#
+#  (INIT.DLINIT has the dlion microcode spliced in.)	#
+#							#
+#########################################################
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv LDEINIT	~/lispcore/sunloadup/INIT.MAKEBIG
+rm ~/REM.CM
+$LDE $FULL_SYSOUT
+
+
+
+#########################################################
+#				   			#
+#	   S T E P   2		   			#
+#				   			#
+#  Using the ldeinit emulator (which has special sup-	#
+#  port for an incomplete lisp world) boot INIT.DLINIT	#
+#  and LOGOUT.  This runs the MAKEINIT.EXPRESSIONS for	#
+#  a bunch of files, which set up much of the		#
+#  infrastructure.					#
+#							#
+#########################################################
+
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+
+# save your lisp.virtualmem
+
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE $LOADDIR/INIT.DLINIT -INIT 
+
+
+#########################################################
+#				   			#
+#	   S T E P   3		   			#
+#				   			#
+#  Start the emulator for the new version, and fire	#
+#  up the lisp.virtualmem from step 2.  Load in the	#
+#  rest of the system, and do a MAKESYS to create the	#
+#  LISP.SYSOUT.						#
+#							#
+#########################################################
+
+set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc)
+set path=( $LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc )
+cp $SECOND_REM_CM ~/REM.CM
+$LDE2 ~/lisp.virtualmem
+
diff --git a/internal/makesysout/sunloadup/runloadbig-sgi b/internal/makesysout/sunloadup/runloadbig-sgi
new file mode 100644
index 00000000..1bbdc02d
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadbig-sgi
@@ -0,0 +1,43 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure thru to FULL.SYSOUT
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDE			= $HOME/maiko/irix.sgi/ldex-small
+set LDE2		= $HOME/maiko/irix.sgi/ldex-bigvm
+set LDEPATH		= $HOME/maiko/irix.sgi
+set INITLDE		= $HOME/maiko/irix.sgi/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sgi
+#set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+#set FULL_SYSOUT = $HOME/FULL.SYSOUT # FULL.SYSOUT
+set FULL_SYSOUT = $HOME/smallFULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADFULL-REM.CM
+#set SECOND_REM_CM = $HOME/SUNLOADUP/LOADBIGFULLFROMLISP-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+#set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+#setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEBIGSGI
+#rm ~/REM.CM
+#$LDE $FULL_SYSOUT
+
+
+# Boot INIT.DLINIT and LOGOUT.
+#set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+#unsetenv LDEDESTSYSOUT
+#cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+#if( -e ~/lisp.virtualmem ) then
+	#mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+#endif
+#$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc)
+set path=( $LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc )
+cp $SECOND_REM_CM ~/REM.CM
+$LDE2 ~/lisp.virtualmem
+#$LDE2 ~/bigLISP.SYSOUT
+
diff --git a/internal/makesysout/sunloadup/runloadcltl2-sgi b/internal/makesysout/sunloadup/runloadcltl2-sgi
new file mode 100644
index 00000000..710d51a4
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadcltl2-sgi
@@ -0,0 +1,42 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure thru to FULL.SYSOUT
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDE			= $HOME/maiko/irix.sgi/lde
+set LDE2		= $HOME/maiko/irix.sgi/lde
+set LDEPATH		= $HOME/maiko/irix.sgi
+set INITLDE		= $HOME/maiko/irix.sgi/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sgi
+#set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+set FULL_SYSOUT = $HOME/bigLISP.SYSOUT
+#set FULL_SYSOUT = $HOME/bigLISP.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADFULL-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKECLTL2SGI
+rm ~/REM.CM
+$LDE $FULL_SYSOUT
+
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+#set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc)
+set path=( $LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc )
+cp $SECOND_REM_CM ~/REM.CM
+$LDE2 ~/lisp.virtualmem
+
+
diff --git a/internal/makesysout/sunloadup/runloadfull b/internal/makesysout/sunloadup/runloadfull
new file mode 100644
index 00000000..16081558
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadfull
@@ -0,0 +1,44 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure thru to FULL.SYSOUT
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+#set LDE			= $HOME/maiko/sunos4.sparc/ldeether
+set LDE				= $HOME/ldeether
+set LDE2				= $HOME/ldeether
+#set LDE2		= $HOME/maiko/sunos4.sparc/ldeether
+set LDEPATH		= $HOME
+set LDE2PATH	= $HOME/maiko/sunos4.sparc
+set INITLDE		= $HOME/maiko/sunos4.sparc/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sparc
+#set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+set FULL_SYSOUT = $HOME/smallFULL.SYSOUT
+set FIRST_REM_CM	= /disk1/lispcore3.0/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= /disk1/lispcore3.0/SUNLOADUP/LOADFULL-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINITFULL
+rm ~/REM.CM
+$LDE $FULL_SYSOUT
+
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc)
+#set path=(/bin /usr/bin /usr/ucb /etc /usr/etc $LDE2PATH)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
+
+
diff --git a/internal/makesysout/sunloadup/runloadfull% b/internal/makesysout/sunloadup/runloadfull%
new file mode 100644
index 00000000..88b336a7
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadfull%
@@ -0,0 +1,38 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure thru to FULL.SYSOUT
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDE			= $HOME/maiko/sunos4.sparc/ldeether
+set LDEPATH		= $HOME/maiko/sunos4.sparc
+set INITLDE		= $HOME/maiko/sunos4.sparc/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sparc
+set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADFULL-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINITFULL
+rm ~/REM.CM
+$LDE $FULL_SYSOUT
+#ldeether $FULL_SYSOUT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
+
+#~/ldemulti3 ~/lisp.virtualmem -NF
diff --git a/internal/makesysout/sunloadup/runloadfull-2nd b/internal/makesysout/sunloadup/runloadfull-2nd
new file mode 100644
index 00000000..6b3ce2b5
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadfull-2nd
@@ -0,0 +1,38 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure thru to FULL.SYSOUT
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDE			= $HOME/maiko/sunos4.sparc/ldeether
+set LDEPATH		= $HOME/maiko/sunos4.sparc
+set INITLDE		= $HOME/maiko/sunos4.sparc/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sparc
+set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADFULL-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+#set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+#setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINITFULL
+#rm ~/REM.CM
+#$LDE $FULL_SYSOUT
+#ldeether $FULL_SYSOUT
+
+# Boot INIT.DLINIT and LOGOUT.
+#set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+#unsetenv LDEDESTSYSOUT
+#cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+#if( -e ~/lisp.virtualmem ) then
+#	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+#endif
+#$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
+
+#~/ldemulti3 ~/lisp.virtualmem -NF
diff --git a/internal/makesysout/sunloadup/runloadfull-dsk b/internal/makesysout/sunloadup/runloadfull-dsk
new file mode 100644
index 00000000..0c845ee1
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadfull-dsk
@@ -0,0 +1,47 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure thru to FULL.SYSOUT
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDEPATH		= $HOME
+#set LDEPATH2	= $HOME/maiko/sunos4.sparc
+set LDEPATH2	= $HOME
+#set LDE			= $LDEPATH/oldldex
+set LDE			= /users/sybalsky/ldeether
+set LDE2		= $LDEPATH/ldemulti
+set INITLDE		= $LDEPATH/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sparc
+#set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+set FULL_SYSOUT = $HOME/smallFULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADFULL-REM.CM
+#
+
+setenv LDEFILETIMEOUT 1000000
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINITDSK
+rm ~/REM.CM
+$LDE $FULL_SYSOUT
+
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+ save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc)
+set path=(/bin /usr/bin /usr/ucb /etc /usr/etc $LDEPATH2)
+cp $SECOND_REM_CM ~/REM.CM
+#newlde
+$LDE ~/lisp.virtualmem
+
+
diff --git a/internal/makesysout/sunloadup/runloadfull-sgi b/internal/makesysout/sunloadup/runloadfull-sgi
new file mode 100644
index 00000000..31e3ac6d
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadfull-sgi
@@ -0,0 +1,42 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure thru to FULL.SYSOUT
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDE			= $HOME/maiko/irix.sgi/ldex-small
+set LDE2		= $HOME/maiko/irix.sgi/lde
+set LDEPATH		= $HOME/maiko/irix.sgi
+set INITLDE		= $HOME/maiko/irix.sgi/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sgi
+#set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+set FULL_SYSOUT = $HOME/smallFULL.SYSOUT
+#set FULL_SYSOUT = $HOME/bigLISP.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADFULL-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+#set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+#setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINITFULLSGI
+#rm ~/REM.CM
+#$LDE $FULL_SYSOUT
+
+
+# Boot INIT.DLINIT and LOGOUT.
+#set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+#unsetenv LDEDESTSYSOUT
+#cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+#if( -e ~/lisp.virtualmem ) then
+	#mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+#endif
+#$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+#set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc)
+set path=( $LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc )
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
+
+
diff --git a/internal/makesysout/sunloadup/runloadfullfromlisp b/internal/makesysout/sunloadup/runloadfullfromlisp
new file mode 100644
index 00000000..67b677d9
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadfullfromlisp
@@ -0,0 +1,38 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure thru to FULL.SYSOUT
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDE			= $HOME/ldeether
+set LDEPATH		= $HOME
+set INITLDE		= $HOME/maiko/sunos4.sparc/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sparc
+#set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+set FULL_SYSOUT		= $HOME/smallFULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADFULLFROMLISP-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+#set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.LOADFULLFROMLISP
+#rm ~/REM.CM
+#$LDE $FULL_SYSOUT
+##ldeether $FULL_SYSOUT
+
+# Boot INIT.DLINIT and LOGOUT.
+#set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+#unsetenv LDEDESTSYSOUT
+#cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+#if( -e ~/lisp.virtualmem ) then
+	#mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+#endif
+#$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+#$LDE ~/lisp.virtualmem
+$LDE $HOME/smallLISP.SYSOUT
diff --git a/internal/makesysout/sunloadup/runloadup b/internal/makesysout/sunloadup/runloadup
new file mode 100644
index 00000000..df736b39
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadup
@@ -0,0 +1,38 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDE			= $HOME/maiko/sunos4.sparc/ldeether
+set LDEPATH		= $HOME
+set INITLDE		= $HOME/maiko/sunos4.sparc/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sparc
+set FULL_SYSOUT		= $HOME/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADUP-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINIT
+rm ~/REM.CM
+#$LDE $FULL_SYSOUT
+ldeether $FULL_SYSOUT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDEPATH/maiko/sunos4.sparc /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
+
+#~/ldemulti3 ~/lisp.virtualmem -NF
diff --git a/internal/makesysout/sunloadup/runloadup% b/internal/makesysout/sunloadup/runloadup%
new file mode 100644
index 00000000..9274b6a0
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadup%
@@ -0,0 +1,38 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDE			= $HOME/maiko/sunos4.sparc/ldeether
+set LDEPATH		= $HOME
+set INITLDE		= $HOME/maiko/sunos4.sparc/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sparc
+set FULL_SYSOUT		= $HOME/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADUP-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINIT
+rm ~/REM.CM
+#$LDE $FULL_SYSOUT
+ldeether $FULL_SYSOUT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
+
+#~/ldemulti3 ~/lisp.virtualmem -NF
diff --git a/internal/makesysout/sunloadup/runloadup-2nd b/internal/makesysout/sunloadup/runloadup-2nd
new file mode 100644
index 00000000..2bb386bb
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadup-2nd
@@ -0,0 +1,31 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure
+#	run 2nd and 3rd step for loadup
+#
+set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDEPATH		= $HOME/maiko/sunos4.sparc
+set INITLDE		= $HOME/maiko/sunos4.sparc/ldeinit
+set INITLDEPATH		= $HOME/maiko/init.sparc
+set FULL_SYSOUT		= /python1/fuji/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADUP-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
diff --git a/internal/makesysout/sunloadup/runloadup-2nd% b/internal/makesysout/sunloadup/runloadup-2nd%
new file mode 100644
index 00000000..7e5cdbe2
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadup-2nd%
@@ -0,0 +1,31 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure
+#	run 2nd and 3rd step for loadup
+#
+set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDEPATH		= $HOME/maiko/sunos4.sparc
+set INITLDE		= $HOME/maiko/init.sparc/lde
+set INITLDEPATH		= $HOME/maiko/init.sparc
+set FULL_SYSOUT		= /python1/fuji/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADUP-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
diff --git a/internal/makesysout/sunloadup/runloadup-2nd-sun3 b/internal/makesysout/sunloadup/runloadup-2nd-sun3
new file mode 100644
index 00000000..686d5618
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadup-2nd-sun3
@@ -0,0 +1,31 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure
+#	run 2nd and 3rd step for loadup
+#
+set LDE			= $HOME/maiko/sunos4.mc68020/lde
+set LDEPATH		= $HOME/maiko/sunos4.mc68020
+set INITLDE		= $HOME/maiko/init.mc68020/lde
+set INITLDEPATH		= $HOME/maiko/init.mc68020
+set FULL_SYSOUT		= /python1/fuji/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADUP-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
diff --git a/internal/makesysout/sunloadup/runloadup-main b/internal/makesysout/sunloadup/runloadup-main
new file mode 100644
index 00000000..e425fe9c
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadup-main
@@ -0,0 +1,34 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure
+#
+set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDEPATH		= $HOME/maiko/sunos4.sparc
+set INITLDE		= $HOME/maiko/init.sparc/lde
+set INITLDEPATH		= $HOME/maiko/init.sparc
+set FULL_SYSOUT		= /python1/fuji/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADUP-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINIT-MAIN
+rm ~/REM.CM
+$LDE $FULL_SYSOUT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
diff --git a/internal/makesysout/sunloadup/runloadup-nodmachine b/internal/makesysout/sunloadup/runloadup-nodmachine
new file mode 100644
index 00000000..ffdc9384
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadup-nodmachine
@@ -0,0 +1,35 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure
+#	Remove D-Machine specific code version
+#
+set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDEPATH		= $HOME/maiko/sunos4.sparc
+set INITLDE		= $HOME/maiko/init.sparc/lde
+set INITLDEPATH		= $HOME/maiko/init.sparc
+set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADUP-NODMACHINE-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINIT
+rm ~/REM.CM
+$LDE $FULL_SYSOUT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
diff --git a/internal/makesysout/sunloadup/runloadup-noether b/internal/makesysout/sunloadup/runloadup-noether
new file mode 100644
index 00000000..9835e7d4
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadup-noether
@@ -0,0 +1,35 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure
+#	NO Ether version
+#
+set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDEPATH		= $HOME/maiko/sunos4.sparc
+set INITLDE		= $HOME/maiko/init.sparc/lde
+set INITLDEPATH		= $HOME/maiko/init.sparc
+set FULL_SYSOUT		= /usr/local/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM-NOETHER.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADUP-NOETHER-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINIT-NOETHER
+rm ~/REM.CM
+$LDE $FULL_SYSOUT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
diff --git a/internal/makesysout/sunloadup/runloadup-nt b/internal/makesysout/sunloadup/runloadup-nt
new file mode 100644
index 00000000..d5c8151f
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadup-nt
@@ -0,0 +1,38 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure
+#
+#set LDE			= $HOME/maiko/sunos4.sparc/lde
+set LDENT			= $HOME/maiko/sunos4.sparc/ldemulti
+set LDENTPATH		= $HOME/maiko/sunos4.sparc
+set INITLDE		= $HOME/maiko/init.sparc/lde
+set INITLDEPATH		= $HOME/maiko/init.sparc
+set FULL_SYSOUT		= /python1/fuji/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADUP-REM.CM
+#
+set LDE		= $HOME/maiko/savelde.sparc/lde
+set LDEPATH		= $HOME/maiko/savelde.sparc
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINIT
+rm ~/REM.CM
+$LDE $FULL_SYSOUT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDENTPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDENT ~/lisp.virtualmem
diff --git a/internal/makesysout/sunloadup/runloadup-sun3 b/internal/makesysout/sunloadup/runloadup-sun3
new file mode 100644
index 00000000..34b8c64c
--- /dev/null
+++ b/internal/makesysout/sunloadup/runloadup-sun3
@@ -0,0 +1,34 @@
+#! /bin/csh -f
+#
+#	automatic loadup procedure
+#
+set LDE			= $HOME/maiko/sunos4.mc68020/lde
+set LDEPATH		= $HOME/maiko/sunos4.mc68020
+set INITLDE		= $HOME/maiko/init.mc68020/lde
+set INITLDEPATH		= $HOME/maiko/init.mc68020
+set FULL_SYSOUT		= /python1/fuji/sysouts/FULL.SYSOUT
+set FIRST_REM_CM	= $HOME/SUNLOADUP/XREM.CM
+set SECOND_REM_CM	= $HOME/SUNLOADUP/LOADUP-REM.CM
+#
+
+#first create INIT.SYSOUT and INIT.DLINIT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+setenv	LDEINIT	$HOME/SUNLOADUP/INIT.MAKEINIT
+rm ~/REM.CM
+$LDE $FULL_SYSOUT
+
+# Boot INIT.DLINIT and LOGOUT.
+set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+unsetenv LDEDESTSYSOUT
+cp $FIRST_REM_CM ~/REM.CM
+# save your lisp.virtualmem
+if( -e ~/lisp.virtualmem ) then
+	mv ~/lisp.virtualmem ~/lisp.virtualmem.save
+endif
+$INITLDE ~/INIT.DLINIT -INIT 
+
+# Finally boot ~/lisp.virtualmem created by previous LOGOUT,
+# and MAKESYS LISP.SYSOUT
+set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc)
+cp $SECOND_REM_CM ~/REM.CM
+$LDE ~/lisp.virtualmem
diff --git a/internal/makesysout/sunloadup/xrem.cm b/internal/makesysout/sunloadup/xrem.cm
new file mode 100644
index 00000000..82ea1e4d
--- /dev/null
+++ b/internal/makesysout/sunloadup/xrem.cm
@@ -0,0 +1 @@
+"
(SETQ SI::*CLOSURE-CACHE-ENABLED* NIL)
(QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT* ))
(MOVD? (QUOTE NILL) (QUOTE PROMPTPRINT))
(MOVD? (QUOTE NILL) (QUOTE CURSORP))
(MOVD? (QUOTE NILL) (QUOTE CHANGEBACKGROUNDBORDER))
(MOVD  (QUOTE \ETHEREVENTFN) (QUOTE \ETHEREVENTFN-))
(MOVD  (QUOTE NILL) (QUOTE \ETHEREVENTFN))
(LOGOUT)
"
\ No newline at end of file
